src/casefiddle.c

   1 /* GNU Emacs case conversion functions.
   2
   3 Copyright (C) 1985, 1994, 1997-1999, 2001-2014 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 to upper case from point to end of word, moving over.
 369
 370 If point is in the middle of a word, the part of that word before point
 371 is ignored when moving forward.
 372
 373 With negative argument, convert previous words but do not move.
 374 See also `capitalize-word'.  */)
 375   (Lisp_Object arg)
 376 {
 377   Lisp_Object beg, end;
 378   ptrdiff_t newpoint;
 379   XSETFASTINT (beg, PT);
 380   end = operate_on_word (arg, &newpoint);
 381   casify_region (CASE_UP, beg, end);
 382   SET_PT (newpoint);
 383   return Qnil;
 384 }
 385
 386 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 387        doc: /* Convert to lower case from point to end of word, moving over.
 388
 389 If point is in the middle of a word, the part of that word before point
 390 is ignored when moving forward.
 391
 392 With negative argument, convert previous words but do not move.  */)
 393   (Lisp_Object arg)
 394 {
 395   Lisp_Object beg, end;
 396   ptrdiff_t newpoint;
 397   XSETFASTINT (beg, PT);
 398   end = operate_on_word (arg, &newpoint);
 399   casify_region (CASE_DOWN, beg, end);
 400   SET_PT (newpoint);
 401   return Qnil;
 402 }
 403
 404 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 405        doc: /* Capitalize from point to the end of word, moving over.
 406 With numerical argument ARG, capitalize the next ARG-1 words as well.
 407 This gives the word(s) a first character in upper case
 408 and the rest lower case.
 409
 410 If point is in the middle of a word, the part of that word before point
 411 is ignored when moving forward.
 412
 413 With negative argument, capitalize previous words but do not move.  */)
 414   (Lisp_Object arg)
 415 {
 416   Lisp_Object beg, end;
 417   ptrdiff_t newpoint;
 418   XSETFASTINT (beg, PT);
 419   end = operate_on_word (arg, &newpoint);
 420   casify_region (CASE_CAPITALIZE, beg, end);
 421   SET_PT (newpoint);
 422   return Qnil;
 423 }
 424 \f
 425 void
 426 syms_of_casefiddle (void)
 427 {
 428   DEFSYM (Qidentity, "identity");
 429   defsubr (&Supcase);
 430   defsubr (&Sdowncase);
 431   defsubr (&Scapitalize);
 432   defsubr (&Supcase_initials);
 433   defsubr (&Supcase_region);
 434   defsubr (&Sdowncase_region);
 435   defsubr (&Scapitalize_region);
 436   defsubr (&Supcase_initials_region);
 437   defsubr (&Supcase_word);
 438   defsubr (&Sdowncase_word);
 439   defsubr (&Scapitalize_word);
 440 }
 441
 442 void
 443 keys_of_casefiddle (void)
 444 {
 445   initial_define_key (control_x_map, Ctl ('U'), "upcase-region");
 446   Fput (intern ("upcase-region"), Qdisabled, Qt);
 447   initial_define_key (control_x_map, Ctl ('L'), "downcase-region");
 448   Fput (intern ("downcase-region"), Qdisabled, Qt);
 449
 450   initial_define_key (meta_map, 'u', "upcase-word");
 451   initial_define_key (meta_map, 'l', "downcase-word");
 452   initial_define_key (meta_map, 'c', "capitalize-word");
 453 }