src/casefiddle.c

   1 /* GNU Emacs case conversion functions.
   2    Copyright (C) 1985, 1994, 1997, 1998, 1999, 2001, 2002, 2003, 2004,
   3                  2005, 2006, 2007, 2008, 2009, 2010 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 "buffer.h"
  25 #include "character.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 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 (current_buffer->downcase_table)->extras[1]))
  43     Fset_case_table (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 (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) XFASTINT (obj) > (unsigned) 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       EMACS_INT i;
  86       EMACS_INT 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       EMACS_INT i, i_byte, size = SCHARS (obj);
 115       int len;
 116       USE_SAFE_ALLOCA;
 117       unsigned char *dst, *o;
 118       /* Over-allocate by 12%: this is a minor overhead, but should be
 119          sufficient in 99.999% of the cases to avoid a reallocation.  */
 120       EMACS_INT o_size = SBYTES (obj) + SBYTES (obj) / 8 + MAX_MULTIBYTE_LENGTH;
 121       SAFE_ALLOCA (dst, void *, o_size);
 122       o = dst;
 123
 124       for (i = i_byte = 0; i < size; i++, i_byte += len)
 125         {
 126           if ((o - dst) + MAX_MULTIBYTE_LENGTH > o_size)
 127             { /* Not enough space for the next char: grow the destination.  */
 128               unsigned char *old_dst = dst;
 129               o_size += o_size; /* Probably overkill, but extremely rare.  */
 130               SAFE_ALLOCA (dst, void *, o_size);
 131               memcpy (dst, old_dst, o - old_dst);
 132               o = dst + (o - old_dst);
 133             }
 134           c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, len);
 135           if (inword && flag != CASE_CAPITALIZE_UP)
 136             c = DOWNCASE (c);
 137           else if (!UPPERCASEP (c)
 138                    && (!inword || flag != CASE_CAPITALIZE_UP))
 139             c = UPCASE1 (c);
 140           if ((int) flag >= (int) CASE_CAPITALIZE)
 141             inword = (SYNTAX (c) == Sword);
 142           o += CHAR_STRING (c, o);
 143         }
 144       eassert (o - dst <= o_size);
 145       obj = make_multibyte_string (dst, size, o - dst);
 146       SAFE_FREE ();
 147       return obj;
 148     }
 149 }
 150
 151 DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
 152        doc: /* Convert argument to upper case and return that.
 153 The argument may be a character or string.  The result has the same type.
 154 The argument object is not altered--the value is a copy.
 155 See also `capitalize', `downcase' and `upcase-initials'.  */)
 156   (Lisp_Object obj)
 157 {
 158   return casify_object (CASE_UP, obj);
 159 }
 160
 161 DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
 162        doc: /* Convert argument to lower case and return that.
 163 The argument may be a character or string.  The result has the same type.
 164 The argument object is not altered--the value is a copy.  */)
 165   (Lisp_Object obj)
 166 {
 167   return casify_object (CASE_DOWN, obj);
 168 }
 169
 170 DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
 171        doc: /* Convert argument to capitalized form and return that.
 172 This means that each word's first character is upper case
 173 and the rest is lower case.
 174 The argument may be a character or string.  The result has the same type.
 175 The argument object is not altered--the value is a copy.  */)
 176   (Lisp_Object obj)
 177 {
 178   return casify_object (CASE_CAPITALIZE, obj);
 179 }
 180
 181 /* Like Fcapitalize but change only the initials.  */
 182
 183 DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0,
 184        doc: /* Convert the initial of each word in the argument to upper case.
 185 Do not change the other letters of each word.
 186 The argument may be a character or string.  The result has the same type.
 187 The argument object is not altered--the value is a copy.  */)
 188   (Lisp_Object obj)
 189 {
 190   return casify_object (CASE_CAPITALIZE_UP, obj);
 191 }
 192 \f
 193 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
 194    b and e specify range of buffer to operate on. */
 195
 196 void
 197 casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e)
 198 {
 199   register int c;
 200   register int inword = flag == CASE_DOWN;
 201   register int multibyte = !NILP (current_buffer->enable_multibyte_characters);
 202   EMACS_INT start, end;
 203   EMACS_INT start_byte, end_byte;
 204   EMACS_INT first = -1, last;   /* Position of first and last changes.  */
 205   EMACS_INT opoint = PT;
 206   EMACS_INT opoint_byte = PT_BYTE;
 207
 208   if (EQ (b, e))
 209     /* Not modifying because nothing marked */
 210     return;
 211
 212   /* If the case table is flagged as modified, rescan it.  */
 213   if (NILP (XCHAR_TABLE (current_buffer->downcase_table)->extras[1]))
 214     Fset_case_table (current_buffer->downcase_table);
 215
 216   validate_region (&b, &e);
 217   start = XFASTINT (b);
 218   end = XFASTINT (e);
 219   modify_region (current_buffer, start, end, 0);
 220   record_change (start, end - start);
 221   start_byte = CHAR_TO_BYTE (start);
 222   end_byte = CHAR_TO_BYTE (end);
 223
 224   SETUP_BUFFER_SYNTAX_TABLE();  /* For syntax_prefix_flag_p.  */
 225
 226   while (start < end)
 227     {
 228       int c2, len;
 229
 230       if (multibyte)
 231         {
 232           c = FETCH_MULTIBYTE_CHAR (start_byte);
 233           len = CHAR_BYTES (c);
 234         }
 235       else
 236         {
 237           c = FETCH_BYTE (start_byte);
 238           MAKE_CHAR_MULTIBYTE (c);
 239           len = 1;
 240         }
 241       c2 = c;
 242       if (inword && flag != CASE_CAPITALIZE_UP)
 243         c = DOWNCASE (c);
 244       else if (!UPPERCASEP (c)
 245                && (!inword || flag != CASE_CAPITALIZE_UP))
 246         c = UPCASE1 (c);
 247       if ((int) flag >= (int) CASE_CAPITALIZE)
 248         inword = ((SYNTAX (c) == Sword)
 249                   && (inword || !syntax_prefix_flag_p (c)));
 250       if (c != c2)
 251         {
 252           last = start;
 253           if (first < 0)
 254             first = start;
 255
 256           if (! multibyte)
 257             {
 258               MAKE_CHAR_UNIBYTE (c);
 259               FETCH_BYTE (start_byte) = c;
 260             }
 261           else if (ASCII_CHAR_P (c2) && ASCII_CHAR_P (c))
 262             FETCH_BYTE (start_byte) = c;
 263           else
 264             {
 265               int tolen = CHAR_BYTES (c);
 266               int j;
 267               unsigned char str[MAX_MULTIBYTE_LENGTH];
 268
 269               CHAR_STRING (c, str);
 270               if (len == tolen)
 271                 {
 272                   /* Length is unchanged.  */
 273                   for (j = 0; j < len; ++j)
 274                     FETCH_BYTE (start_byte + j) = str[j];
 275                 }
 276               else
 277                 {
 278                   /* Replace one character with the other,
 279                      keeping text properties the same.  */
 280                   replace_range_2 (start, start_byte,
 281                                    start + 1, start_byte + len,
 282                                    str, 1, tolen,
 283                                    0);
 284                   len = tolen;
 285                 }
 286             }
 287         }
 288       start++;
 289       start_byte += len;
 290     }
 291
 292   if (PT != opoint)
 293     TEMP_SET_PT_BOTH (opoint, opoint_byte);
 294
 295   if (first >= 0)
 296     {
 297       signal_after_change (first, last + 1 - first, last + 1 - first);
 298       update_compositions (first, last + 1, CHECK_ALL);
 299     }
 300 }
 301
 302 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
 303        doc: /* Convert the region to upper case.  In programs, wants two arguments.
 304 These arguments specify the starting and ending character numbers of
 305 the region to operate on.  When used as a command, the text between
 306 point and the mark is operated on.
 307 See also `capitalize-region'.  */)
 308   (Lisp_Object beg, Lisp_Object end)
 309 {
 310   casify_region (CASE_UP, beg, end);
 311   return Qnil;
 312 }
 313
 314 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
 315        doc: /* Convert the region to lower case.  In programs, wants two arguments.
 316 These arguments specify the starting and ending character numbers of
 317 the region to operate on.  When used as a command, the text between
 318 point and the mark is operated on.  */)
 319   (Lisp_Object beg, Lisp_Object end)
 320 {
 321   casify_region (CASE_DOWN, beg, end);
 322   return Qnil;
 323 }
 324
 325 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
 326        doc: /* Convert the region to capitalized form.
 327 Capitalized form means each word's first character is upper case
 328 and the rest of it is lower case.
 329 In programs, give two arguments, the starting and ending
 330 character positions to operate on.  */)
 331   (Lisp_Object beg, Lisp_Object end)
 332 {
 333   casify_region (CASE_CAPITALIZE, beg, end);
 334   return Qnil;
 335 }
 336
 337 /* Like Fcapitalize_region but change only the initials.  */
 338
 339 DEFUN ("upcase-initials-region", Fupcase_initials_region,
 340        Supcase_initials_region, 2, 2, "r",
 341        doc: /* Upcase the initial of each word in the region.
 342 Subsequent letters of each word are not changed.
 343 In programs, give two arguments, the starting and ending
 344 character positions to operate on.  */)
 345   (Lisp_Object beg, Lisp_Object end)
 346 {
 347   casify_region (CASE_CAPITALIZE_UP, beg, end);
 348   return Qnil;
 349 }
 350 \f
 351 static Lisp_Object
 352 operate_on_word (Lisp_Object arg, EMACS_INT *newpoint)
 353 {
 354   Lisp_Object val;
 355   EMACS_INT farend;
 356   EMACS_INT iarg;
 357
 358   CHECK_NUMBER (arg);
 359   iarg = XINT (arg);
 360   farend = scan_words (PT, iarg);
 361   if (!farend)
 362     farend = iarg > 0 ? ZV : BEGV;
 363
 364   *newpoint = PT > farend ? PT : farend;
 365   XSETFASTINT (val, farend);
 366
 367   return val;
 368 }
 369
 370 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
 371        doc: /* Convert following word (or ARG words) to upper case, moving over.
 372 With negative argument, convert previous words but do not move.
 373 See also `capitalize-word'.  */)
 374   (Lisp_Object arg)
 375 {
 376   Lisp_Object beg, end;
 377   EMACS_INT newpoint;
 378   XSETFASTINT (beg, PT);
 379   end = operate_on_word (arg, &newpoint);
 380   casify_region (CASE_UP, beg, end);
 381   SET_PT (newpoint);
 382   return Qnil;
 383 }
 384
 385 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 386        doc: /* Convert following word (or ARG words) to lower case, moving over.
 387 With negative argument, convert previous words but do not move.  */)
 388   (Lisp_Object arg)
 389 {
 390   Lisp_Object beg, end;
 391   EMACS_INT newpoint;
 392   XSETFASTINT (beg, PT);
 393   end = operate_on_word (arg, &newpoint);
 394   casify_region (CASE_DOWN, beg, end);
 395   SET_PT (newpoint);
 396   return Qnil;
 397 }
 398
 399 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 400        doc: /* Capitalize the following word (or ARG words), moving over.
 401 This gives the word(s) a first character in upper case
 402 and the rest lower case.
 403 With negative argument, capitalize previous words but do not move.  */)
 404   (Lisp_Object arg)
 405 {
 406   Lisp_Object beg, end;
 407   EMACS_INT newpoint;
 408   XSETFASTINT (beg, PT);
 409   end = operate_on_word (arg, &newpoint);
 410   casify_region (CASE_CAPITALIZE, beg, end);
 411   SET_PT (newpoint);
 412   return Qnil;
 413 }
 414 \f
 415 void
 416 syms_of_casefiddle (void)
 417 {
 418   Qidentity = intern_c_string ("identity");
 419   staticpro (&Qidentity);
 420   defsubr (&Supcase);
 421   defsubr (&Sdowncase);
 422   defsubr (&Scapitalize);
 423   defsubr (&Supcase_initials);
 424   defsubr (&Supcase_region);
 425   defsubr (&Sdowncase_region);
 426   defsubr (&Scapitalize_region);
 427   defsubr (&Supcase_initials_region);
 428   defsubr (&Supcase_word);
 429   defsubr (&Sdowncase_word);
 430   defsubr (&Scapitalize_word);
 431 }
 432
 433 void
 434 keys_of_casefiddle (void)
 435 {
 436   initial_define_key (control_x_map, Ctl('U'), "upcase-region");
 437   Fput (intern ("upcase-region"), Qdisabled, Qt);
 438   initial_define_key (control_x_map, Ctl('L'), "downcase-region");
 439   Fput (intern ("downcase-region"), Qdisabled, Qt);
 440
 441   initial_define_key (meta_map, 'u', "upcase-word");
 442   initial_define_key (meta_map, 'l', "downcase-word");
 443   initial_define_key (meta_map, 'c', "capitalize-word");
 444 }
 445
 446 /* arch-tag: 60a73c66-5489-47e7-a81f-cead4057c526
 447    (do not change this comment) */