src/casefiddle.c

   1 /* GNU Emacs case conversion functions.
   2
   3 Copyright (C) 1985, 1994, 1997-1999, 2001-2012 Free Software Foundation, Inc.
   4
   5 This file is part of GNU Emacs.
   6
   7 GNU Emacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 GNU Emacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20
  21 #include <config.h>
  22 #include <setjmp.h>
  23 #include "lisp.h"
  24 #include "character.h"
  25 #include "buffer.h"
  26 #include "commands.h"
  27 #include "syntax.h"
  28 #include "composite.h"
  29 #include "keymap.h"
  30
  31 enum case_action {CASE_UP, CASE_DOWN, CASE_CAPITALIZE, CASE_CAPITALIZE_UP};
  32
  33 Lisp_Object Qidentity;
  34 \f
  35 static Lisp_Object
  36 casify_object (enum case_action flag, Lisp_Object obj)
  37 {
  38   register int c, c1;
  39   register int inword = flag == CASE_DOWN;
  40
  41   /* If the case table is flagged as modified, rescan it.  */
  42   if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
  43     Fset_case_table (BVAR (current_buffer, downcase_table));
  44
  45   if (INTEGERP (obj))
  46     {
  47       int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
  48                       | CHAR_SHIFT | CHAR_CTL | CHAR_META);
  49       int flags = XINT (obj) & flagbits;
  50       int multibyte = ! NILP (BVAR (current_buffer, 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   register int c;
 193   register int inword = flag == CASE_DOWN;
 194   register int 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_region (current_buffer, start, end, 0);
 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 following word (or ARG words) to upper case, moving over.
 367 With negative argument, convert previous words but do not move.
 368 See also `capitalize-word'.  */)
 369   (Lisp_Object arg)
 370 {
 371   Lisp_Object beg, end;
 372   ptrdiff_t newpoint;
 373   XSETFASTINT (beg, PT);
 374   end = operate_on_word (arg, &newpoint);
 375   casify_region (CASE_UP, beg, end);
 376   SET_PT (newpoint);
 377   return Qnil;
 378 }
 379
 380 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 381        doc: /* Convert following word (or ARG words) to lower case, moving over.
 382 With negative argument, convert previous words but do not move.  */)
 383   (Lisp_Object arg)
 384 {
 385   Lisp_Object beg, end;
 386   ptrdiff_t newpoint;
 387   XSETFASTINT (beg, PT);
 388   end = operate_on_word (arg, &newpoint);
 389   casify_region (CASE_DOWN, beg, end);
 390   SET_PT (newpoint);
 391   return Qnil;
 392 }
 393
 394 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 395        doc: /* Capitalize the following word (or ARG words), moving over.
 396 This gives the word(s) a first character in upper case
 397 and the rest lower case.
 398 With negative argument, capitalize previous words but do not move.  */)
 399   (Lisp_Object arg)
 400 {
 401   Lisp_Object beg, end;
 402   ptrdiff_t newpoint;
 403   XSETFASTINT (beg, PT);
 404   end = operate_on_word (arg, &newpoint);
 405   casify_region (CASE_CAPITALIZE, beg, end);
 406   SET_PT (newpoint);
 407   return Qnil;
 408 }
 409 \f
 410 void
 411 syms_of_casefiddle (void)
 412 {
 413   DEFSYM (Qidentity, "identity");
 414   defsubr (&Supcase);
 415   defsubr (&Sdowncase);
 416   defsubr (&Scapitalize);
 417   defsubr (&Supcase_initials);
 418   defsubr (&Supcase_region);
 419   defsubr (&Sdowncase_region);
 420   defsubr (&Scapitalize_region);
 421   defsubr (&Supcase_initials_region);
 422   defsubr (&Supcase_word);
 423   defsubr (&Sdowncase_word);
 424   defsubr (&Scapitalize_word);
 425 }
 426
 427 void
 428 keys_of_casefiddle (void)
 429 {
 430   initial_define_key (control_x_map, Ctl ('U'), "upcase-region");
 431   Fput (intern ("upcase-region"), Qdisabled, Qt);
 432   initial_define_key (control_x_map, Ctl ('L'), "downcase-region");
 433   Fput (intern ("downcase-region"), Qdisabled, Qt);
 434
 435   initial_define_key (meta_map, 'u', "upcase-word");
 436   initial_define_key (meta_map, 'l', "downcase-word");
 437   initial_define_key (meta_map, 'c', "capitalize-word");
 438 }