src/casefiddle.c

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