src/casefiddle.c

   1 /* GNU Emacs case conversion functions.
   2
   3 Copyright (C) 1985, 1994, 1997-1999, 2001-2013 Free Software Foundation,
   4 Inc.
   5
   6 This file is part of GNU Emacs.
   7
   8 GNU Emacs is free software: you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation, either version 3 of the License, or
  11 (at your option) any later version.
  12
  13 GNU Emacs is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  20
  21
  22 #include <config.h>
  23
  24 #include "lisp.h"
  25 #include "character.h"
  26 #include "buffer.h"
  27 #include "commands.h"
  28 #include "syntax.h"
  29 #include "composite.h"
  30 #include "keymap.h"
  31
  32 enum case_action {CASE_UP, CASE_DOWN, CASE_CAPITALIZE, CASE_CAPITALIZE_UP};
  33
  34 Lisp_Object Qidentity;
  35 \f
  36 static Lisp_Object
  37 casify_object (enum case_action flag, Lisp_Object obj)
  38 {
  39   int c, c1;
  40   bool inword = flag == CASE_DOWN;
  41
  42   /* If the case table is flagged as modified, rescan it.  */
  43   if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
  44     Fset_case_table (BVAR (current_buffer, downcase_table));
  45
  46   if (INTEGERP (obj))
  47     {
  48       int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
  49                       | CHAR_SHIFT | CHAR_CTL | CHAR_META);
  50       int flags = XINT (obj) & flagbits;
  51       bool multibyte = ! NILP (BVAR (current_buffer,
  52                                      enable_multibyte_characters));
  53
  54       /* If the character has higher bits set
  55          above the flags, return it unchanged.
  56          It is not a real character.  */
  57       if (UNSIGNED_CMP (XFASTINT (obj), >, flagbits))
  58         return obj;
  59
  60       c1 = XFASTINT (obj) & ~flagbits;
  61       /* FIXME: Even if enable-multibyte-characters is nil, we may
  62          manipulate multibyte chars.  This means we have a bug for latin-1
  63          chars since when we receive an int 128-255 we can't tell whether
  64          it's an eight-bit byte or a latin-1 char.  */
  65       if (c1 >= 256)
  66         multibyte = 1;
  67       if (! multibyte)
  68         MAKE_CHAR_MULTIBYTE (c1);
  69       c = downcase (c1);
  70       if (inword)
  71         XSETFASTINT (obj, c | flags);
  72       else if (c == (XFASTINT (obj) & ~flagbits))
  73         {
  74           if (! inword)
  75             c = upcase1 (c1);
  76           if (! multibyte)
  77             MAKE_CHAR_UNIBYTE (c);
  78           XSETFASTINT (obj, c | flags);
  79         }
  80       return obj;
  81     }
  82
  83   if (!STRINGP (obj))
  84     wrong_type_argument (Qchar_or_string_p, obj);
  85   else if (!STRING_MULTIBYTE (obj))
  86     {
  87       ptrdiff_t i;
  88       ptrdiff_t size = SCHARS (obj);
  89
  90       obj = Fcopy_sequence (obj);
  91       for (i = 0; i < size; i++)
  92         {
  93           c = SREF (obj, i);
  94           MAKE_CHAR_MULTIBYTE (c);
  95           c1 = c;
  96           if (inword && flag != CASE_CAPITALIZE_UP)
  97             c = downcase (c);
  98           else if (!uppercasep (c)
  99                    && (!inword || flag != CASE_CAPITALIZE_UP))
 100             c = upcase1 (c1);
 101           if ((int) flag >= (int) CASE_CAPITALIZE)
 102             inword = (SYNTAX (c) == Sword);
 103           if (c != c1)
 104             {
 105                   MAKE_CHAR_UNIBYTE (c);
 106               /* If the char can't be converted to a valid byte, just don't
 107                  change it.  */
 108               if (c >= 0 && c < 256)
 109                 SSET (obj, i, c);
 110             }
 111         }
 112       return obj;
 113     }
 114   else
 115     {
 116       ptrdiff_t i, i_byte, size = SCHARS (obj);
 117       int len;
 118       USE_SAFE_ALLOCA;
 119       ptrdiff_t o_size = (size < STRING_BYTES_BOUND / MAX_MULTIBYTE_LENGTH
 120                           ? size * MAX_MULTIBYTE_LENGTH
 121                           : STRING_BYTES_BOUND);
 122       unsigned char *dst = SAFE_ALLOCA (o_size);
 123       unsigned char *o = dst;
 124
 125       for (i = i_byte = 0; i < size; i++, i_byte += len)
 126         {
 127           if (o_size - (o - dst) < MAX_MULTIBYTE_LENGTH)
 128             string_overflow ();
 129           c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, len);
 130           if (inword && flag != CASE_CAPITALIZE_UP)
 131             c = downcase (c);
 132           else if (!uppercasep (c)
 133                    && (!inword || flag != CASE_CAPITALIZE_UP))
 134             c = upcase1 (c);
 135           if ((int) flag >= (int) CASE_CAPITALIZE)
 136             inword = (SYNTAX (c) == Sword);
 137           o += CHAR_STRING (c, o);
 138         }
 139       eassert (o - dst <= o_size);
 140       obj = make_multibyte_string ((char *) dst, size, o - dst);
 141       SAFE_FREE ();
 142       return obj;
 143     }
 144 }
 145
 146 DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
 147        doc: /* Convert argument to upper case and return that.
 148 The argument may be a character or string.  The result has the same type.
 149 The argument object is not altered--the value is a copy.
 150 See also `capitalize', `downcase' and `upcase-initials'.  */)
 151   (Lisp_Object obj)
 152 {
 153   return casify_object (CASE_UP, obj);
 154 }
 155
 156 DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
 157        doc: /* Convert argument to lower case and return that.
 158 The argument may be a character or string.  The result has the same type.
 159 The argument object is not altered--the value is a copy.  */)
 160   (Lisp_Object obj)
 161 {
 162   return casify_object (CASE_DOWN, obj);
 163 }
 164
 165 DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
 166        doc: /* Convert argument to capitalized form and return that.
 167 This means that each word's first character is upper case
 168 and the rest is lower case.
 169 The argument may be a character or string.  The result has the same type.
 170 The argument object is not altered--the value is a copy.  */)
 171   (Lisp_Object obj)
 172 {
 173   return casify_object (CASE_CAPITALIZE, obj);
 174 }
 175
 176 /* Like Fcapitalize but change only the initials.  */
 177
 178 DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0,
 179        doc: /* Convert the initial of each word in the argument to upper case.
 180 Do not change the other letters of each word.
 181 The argument may be a character or string.  The result has the same type.
 182 The argument object is not altered--the value is a copy.  */)
 183   (Lisp_Object obj)
 184 {
 185   return casify_object (CASE_CAPITALIZE_UP, obj);
 186 }
 187 \f
 188 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
 189    b and e specify range of buffer to operate on. */
 190
 191 static void
 192 casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e)
 193 {
 194   int c;
 195   bool inword = flag == CASE_DOWN;
 196   bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
 197   ptrdiff_t start, end;
 198   ptrdiff_t start_byte;
 199
 200   /* Position of first and last changes.  */
 201   ptrdiff_t first = -1, last IF_LINT (= 0);
 202
 203   ptrdiff_t opoint = PT;
 204   ptrdiff_t opoint_byte = PT_BYTE;
 205
 206   if (EQ (b, e))
 207     /* Not modifying because nothing marked */
 208     return;
 209
 210   /* If the case table is flagged as modified, rescan it.  */
 211   if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
 212     Fset_case_table (BVAR (current_buffer, downcase_table));
 213
 214   validate_region (&b, &e);
 215   start = XFASTINT (b);
 216   end = XFASTINT (e);
 217   modify_text (start, end);
 218   record_change (start, end - start);
 219   start_byte = CHAR_TO_BYTE (start);
 220
 221   SETUP_BUFFER_SYNTAX_TABLE (); /* For syntax_prefix_flag_p.  */
 222
 223   while (start < end)
 224     {
 225       int c2, len;
 226
 227       if (multibyte)
 228         {
 229           c = FETCH_MULTIBYTE_CHAR (start_byte);
 230           len = CHAR_BYTES (c);
 231         }
 232       else
 233         {
 234           c = FETCH_BYTE (start_byte);
 235           MAKE_CHAR_MULTIBYTE (c);
 236           len = 1;
 237         }
 238       c2 = c;
 239       if (inword && flag != CASE_CAPITALIZE_UP)
 240         c = downcase (c);
 241       else if (!uppercasep (c)
 242                && (!inword || flag != CASE_CAPITALIZE_UP))
 243         c = upcase1 (c);
 244       if ((int) flag >= (int) CASE_CAPITALIZE)
 245         inword = ((SYNTAX (c) == Sword)
 246                   && (inword || !syntax_prefix_flag_p (c)));
 247       if (c != c2)
 248         {
 249           last = start;
 250           if (first < 0)
 251             first = start;
 252
 253           if (! multibyte)
 254             {
 255               MAKE_CHAR_UNIBYTE (c);
 256               FETCH_BYTE (start_byte) = c;
 257             }
 258           else if (ASCII_CHAR_P (c2) && ASCII_CHAR_P (c))
 259             FETCH_BYTE (start_byte) = c;
 260           else
 261             {
 262               int tolen = CHAR_BYTES (c);
 263               int j;
 264               unsigned char str[MAX_MULTIBYTE_LENGTH];
 265
 266               CHAR_STRING (c, str);
 267               if (len == tolen)
 268                 {
 269                   /* Length is unchanged.  */
 270                   for (j = 0; j < len; ++j)
 271                     FETCH_BYTE (start_byte + j) = str[j];
 272                 }
 273               else
 274                 {
 275                   /* Replace one character with the other,
 276                      keeping text properties the same.  */
 277                   replace_range_2 (start, start_byte,
 278                                    start + 1, start_byte + len,
 279                                    (char *) str, 1, tolen,
 280                                    0);
 281                   len = tolen;
 282                 }
 283             }
 284         }
 285       start++;
 286       start_byte += len;
 287     }
 288
 289   if (PT != opoint)
 290     TEMP_SET_PT_BOTH (opoint, opoint_byte);
 291
 292   if (first >= 0)
 293     {
 294       signal_after_change (first, last + 1 - first, last + 1 - first);
 295       update_compositions (first, last + 1, CHECK_ALL);
 296     }
 297 }
 298
 299 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
 300        doc: /* Convert the region to upper case.  In programs, wants two arguments.
 301 These arguments specify the starting and ending character numbers of
 302 the region to operate on.  When used as a command, the text between
 303 point and the mark is operated on.
 304 See also `capitalize-region'.  */)
 305   (Lisp_Object beg, Lisp_Object end)
 306 {
 307   casify_region (CASE_UP, beg, end);
 308   return Qnil;
 309 }
 310
 311 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
 312        doc: /* Convert the region to lower case.  In programs, wants two arguments.
 313 These arguments specify the starting and ending character numbers of
 314 the region to operate on.  When used as a command, the text between
 315 point and the mark is operated on.  */)
 316   (Lisp_Object beg, Lisp_Object end)
 317 {
 318   casify_region (CASE_DOWN, beg, end);
 319   return Qnil;
 320 }
 321
 322 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
 323        doc: /* Convert the region to capitalized form.
 324 Capitalized form means each word's first character is upper case
 325 and the rest of it is lower case.
 326 In programs, give two arguments, the starting and ending
 327 character positions to operate on.  */)
 328   (Lisp_Object beg, Lisp_Object end)
 329 {
 330   casify_region (CASE_CAPITALIZE, beg, end);
 331   return Qnil;
 332 }
 333
 334 /* Like Fcapitalize_region but change only the initials.  */
 335
 336 DEFUN ("upcase-initials-region", Fupcase_initials_region,
 337        Supcase_initials_region, 2, 2, "r",
 338        doc: /* Upcase the initial of each word in the region.
 339 Subsequent letters of each word are not changed.
 340 In programs, give two arguments, the starting and ending
 341 character positions to operate on.  */)
 342   (Lisp_Object beg, Lisp_Object end)
 343 {
 344   casify_region (CASE_CAPITALIZE_UP, beg, end);
 345   return Qnil;
 346 }
 347 \f
 348 static Lisp_Object
 349 operate_on_word (Lisp_Object arg, ptrdiff_t *newpoint)
 350 {
 351   Lisp_Object val;
 352   ptrdiff_t farend;
 353   EMACS_INT iarg;
 354
 355   CHECK_NUMBER (arg);
 356   iarg = XINT (arg);
 357   farend = scan_words (PT, iarg);
 358   if (!farend)
 359     farend = iarg > 0 ? ZV : BEGV;
 360
 361   *newpoint = PT > farend ? PT : farend;
 362   XSETFASTINT (val, farend);
 363
 364   return val;
 365 }
 366
 367 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
 368        doc: /* Convert following word (or ARG words) to upper case, moving over.
 369 With negative argument, convert previous words but do not move.
 370 See also `capitalize-word'.  */)
 371   (Lisp_Object arg)
 372 {
 373   Lisp_Object beg, end;
 374   ptrdiff_t newpoint;
 375   XSETFASTINT (beg, PT);
 376   end = operate_on_word (arg, &newpoint);
 377   casify_region (CASE_UP, beg, end);
 378   SET_PT (newpoint);
 379   return Qnil;
 380 }
 381
 382 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 383        doc: /* Convert following word (or ARG words) to lower case, moving over.
 384 With negative argument, convert previous words but do not move.  */)
 385   (Lisp_Object arg)
 386 {
 387   Lisp_Object beg, end;
 388   ptrdiff_t newpoint;
 389   XSETFASTINT (beg, PT);
 390   end = operate_on_word (arg, &newpoint);
 391   casify_region (CASE_DOWN, beg, end);
 392   SET_PT (newpoint);
 393   return Qnil;
 394 }
 395
 396 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 397        doc: /* Capitalize the following word (or ARG words), moving over.
 398 This gives the word(s) a first character in upper case
 399 and the rest lower case.
 400 With negative argument, capitalize previous words but do not move.  */)
 401   (Lisp_Object arg)
 402 {
 403   Lisp_Object beg, end;
 404   ptrdiff_t newpoint;
 405   XSETFASTINT (beg, PT);
 406   end = operate_on_word (arg, &newpoint);
 407   casify_region (CASE_CAPITALIZE, beg, end);
 408   SET_PT (newpoint);
 409   return Qnil;
 410 }
 411 \f
 412 void
 413 syms_of_casefiddle (void)
 414 {
 415   DEFSYM (Qidentity, "identity");
 416   defsubr (&Supcase);
 417   defsubr (&Sdowncase);
 418   defsubr (&Scapitalize);
 419   defsubr (&Supcase_initials);
 420   defsubr (&Supcase_region);
 421   defsubr (&Sdowncase_region);
 422   defsubr (&Scapitalize_region);
 423   defsubr (&Supcase_initials_region);
 424   defsubr (&Supcase_word);
 425   defsubr (&Sdowncase_word);
 426   defsubr (&Scapitalize_word);
 427 }
 428
 429 void
 430 keys_of_casefiddle (void)
 431 {
 432   initial_define_key (control_x_map, Ctl ('U'), "upcase-region");
 433   Fput (intern ("upcase-region"), Qdisabled, Qt);
 434   initial_define_key (control_x_map, Ctl ('L'), "downcase-region");
 435   Fput (intern ("downcase-region"), Qdisabled, Qt);
 436
 437   initial_define_key (meta_map, 'u', "upcase-word");
 438   initial_define_key (meta_map, 'l', "downcase-word");
 439   initial_define_key (meta_map, 'c', "capitalize-word");
 440 }