src/casefiddle.c

   1 /* GNU Emacs case conversion functions.
   2
   3 Copyright (C) 1985, 1994, 1997-1999, 2001-2015 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 \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 = (size < STRING_BYTES_BOUND / MAX_MULTIBYTE_LENGTH
 118                           ? size * MAX_MULTIBYTE_LENGTH
 119                           : STRING_BYTES_BOUND);
 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 - (o - dst) < MAX_MULTIBYTE_LENGTH)
 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 IF_LINT (= 0);
 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, 2, "r",
 298        doc: /* Convert the region to upper case.  In programs, wants two arguments.
 299 These arguments specify the starting and ending character numbers of
 300 the region to operate on.  When used as a command, the text between
 301 point and the mark is operated on.
 302 See also `capitalize-region'.  */)
 303   (Lisp_Object beg, Lisp_Object end)
 304 {
 305   casify_region (CASE_UP, beg, end);
 306   return Qnil;
 307 }
 308
 309 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
 310        doc: /* Convert the region to lower case.  In programs, wants two arguments.
 311 These arguments specify the starting and ending character numbers of
 312 the region to operate on.  When used as a command, the text between
 313 point and the mark is operated on.  */)
 314   (Lisp_Object beg, Lisp_Object end)
 315 {
 316   casify_region (CASE_DOWN, beg, end);
 317   return Qnil;
 318 }
 319
 320 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
 321        doc: /* Convert the region to capitalized form.
 322 Capitalized form means each word's first character is upper case
 323 and the rest of it is lower case.
 324 In programs, give two arguments, the starting and ending
 325 character positions to operate on.  */)
 326   (Lisp_Object beg, Lisp_Object end)
 327 {
 328   casify_region (CASE_CAPITALIZE, beg, end);
 329   return Qnil;
 330 }
 331
 332 /* Like Fcapitalize_region but change only the initials.  */
 333
 334 DEFUN ("upcase-initials-region", Fupcase_initials_region,
 335        Supcase_initials_region, 2, 2, "r",
 336        doc: /* Upcase the initial of each word in the region.
 337 Subsequent letters of each word are not changed.
 338 In programs, give two arguments, the starting and ending
 339 character positions to operate on.  */)
 340   (Lisp_Object beg, Lisp_Object end)
 341 {
 342   casify_region (CASE_CAPITALIZE_UP, beg, end);
 343   return Qnil;
 344 }
 345 \f
 346 static Lisp_Object
 347 operate_on_word (Lisp_Object arg, ptrdiff_t *newpoint)
 348 {
 349   Lisp_Object val;
 350   ptrdiff_t farend;
 351   EMACS_INT iarg;
 352
 353   CHECK_NUMBER (arg);
 354   iarg = XINT (arg);
 355   farend = scan_words (PT, iarg);
 356   if (!farend)
 357     farend = iarg > 0 ? ZV : BEGV;
 358
 359   *newpoint = PT > farend ? PT : farend;
 360   XSETFASTINT (val, farend);
 361
 362   return val;
 363 }
 364
 365 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
 366        doc: /* Convert to upper case from point to end of word, moving over.
 367
 368 If point is in the middle of a word, the part of that word before point
 369 is ignored when moving forward.
 370
 371 With negative argument, convert previous words but do not move.
 372 See also `capitalize-word'.  */)
 373   (Lisp_Object arg)
 374 {
 375   Lisp_Object beg, end;
 376   ptrdiff_t newpoint;
 377   XSETFASTINT (beg, PT);
 378   end = operate_on_word (arg, &newpoint);
 379   casify_region (CASE_UP, beg, end);
 380   SET_PT (newpoint);
 381   return Qnil;
 382 }
 383
 384 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 385        doc: /* Convert to lower case from point to end of word, moving over.
 386
 387 If point is in the middle of a word, the part of that word before point
 388 is ignored when moving forward.
 389
 390 With negative argument, convert previous words but do not move.  */)
 391   (Lisp_Object arg)
 392 {
 393   Lisp_Object beg, end;
 394   ptrdiff_t newpoint;
 395   XSETFASTINT (beg, PT);
 396   end = operate_on_word (arg, &newpoint);
 397   casify_region (CASE_DOWN, beg, end);
 398   SET_PT (newpoint);
 399   return Qnil;
 400 }
 401
 402 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 403        doc: /* Capitalize from point to the end of word, moving over.
 404 With numerical argument ARG, capitalize the next ARG-1 words as well.
 405 This gives the word(s) a first character in upper case
 406 and the rest lower case.
 407
 408 If point is in the middle of a word, the part of that word before point
 409 is ignored when moving forward.
 410
 411 With negative argument, capitalize previous words but do not move.  */)
 412   (Lisp_Object arg)
 413 {
 414   Lisp_Object beg, end;
 415   ptrdiff_t newpoint;
 416   XSETFASTINT (beg, PT);
 417   end = operate_on_word (arg, &newpoint);
 418   casify_region (CASE_CAPITALIZE, beg, end);
 419   SET_PT (newpoint);
 420   return Qnil;
 421 }
 422 \f
 423 void
 424 syms_of_casefiddle (void)
 425 {
 426   DEFSYM (Qidentity, "identity");
 427   defsubr (&Supcase);
 428   defsubr (&Sdowncase);
 429   defsubr (&Scapitalize);
 430   defsubr (&Supcase_initials);
 431   defsubr (&Supcase_region);
 432   defsubr (&Sdowncase_region);
 433   defsubr (&Scapitalize_region);
 434   defsubr (&Supcase_initials_region);
 435   defsubr (&Supcase_word);
 436   defsubr (&Sdowncase_word);
 437   defsubr (&Scapitalize_word);
 438 }
 439
 440 void
 441 keys_of_casefiddle (void)
 442 {
 443   initial_define_key (control_x_map, Ctl ('U'), "upcase-region");
 444   Fput (intern ("upcase-region"), Qdisabled, Qt);
 445   initial_define_key (control_x_map, Ctl ('L'), "downcase-region");
 446   Fput (intern ("downcase-region"), Qdisabled, Qt);
 447
 448   initial_define_key (meta_map, 'u', "upcase-word");
 449   initial_define_key (meta_map, 'l', "downcase-word");
 450   initial_define_key (meta_map, 'c', "capitalize-word");
 451 }