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 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 "lisp.h"
  23 #include "buffer.h"
  24 #include "character.h"
  25 #include "commands.h"
  26 #include "syntax.h"
  27 #include "composite.h"
  28 #include "keymap.h"
  29
  30 enum case_action {CASE_UP, CASE_DOWN, CASE_CAPITALIZE, CASE_CAPITALIZE_UP};
  31
  32 Lisp_Object Qidentity;
  33 \f
  34 Lisp_Object
  35 casify_object (flag, obj)
  36      enum case_action flag;
  37      Lisp_Object obj;
  38 {
  39   register int c, c1;
  40   register int inword = flag == CASE_DOWN;
  41
  42   /* If the case table is flagged as modified, rescan it.  */
  43   if (NILP (XCHAR_TABLE (current_buffer->downcase_table)->extras[1]))
  44     Fset_case_table (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       int multibyte = ! NILP (current_buffer->enable_multibyte_characters);
  52
  53       /* If the character has higher bits set
  54          above the flags, return it unchanged.
  55          It is not a real character.  */
  56       if ((unsigned) XFASTINT (obj) > (unsigned) flagbits)
  57         return obj;
  58
  59       c1 = XFASTINT (obj) & ~flagbits;
  60       if (! multibyte)
  61         MAKE_CHAR_MULTIBYTE (c1);
  62       c = DOWNCASE (c1);
  63       if (inword)
  64         XSETFASTINT (obj, c | flags);
  65       else if (c == (XFASTINT (obj) & ~flagbits))
  66         {
  67           if (! inword)
  68             c = UPCASE1 (c1);
  69           if (! multibyte)
  70             MAKE_CHAR_UNIBYTE (c);
  71           XSETFASTINT (obj, c | flags);
  72         }
  73       return obj;
  74     }
  75
  76   if (!STRINGP (obj))
  77     wrong_type_argument (Qchar_or_string_p, obj);
  78   else if (!STRING_MULTIBYTE (obj))
  79     {
  80       EMACS_INT i;
  81       EMACS_INT size = SCHARS (obj);
  82
  83       obj = Fcopy_sequence (obj);
  84       for (i = 0; i < size; i++)
  85         {
  86           c = SREF (obj, i);
  87               MAKE_CHAR_MULTIBYTE (c);
  88           c1 = c;
  89           if (inword && flag != CASE_CAPITALIZE_UP)
  90             c = DOWNCASE (c);
  91           else if (!UPPERCASEP (c)
  92                    && (!inword || flag != CASE_CAPITALIZE_UP))
  93             c = UPCASE1 (c1);
  94           if ((int) flag >= (int) CASE_CAPITALIZE)
  95             inword = (SYNTAX (c) == Sword);
  96           if (c != c1)
  97             {
  98                   MAKE_CHAR_UNIBYTE (c);
  99               /* If the char can't be converted to a valid byte, just don't
 100                  change it.  */
 101               if (c >= 0 && c < 256)
 102                 SSET (obj, i, c);
 103             }
 104         }
 105       return obj;
 106     }
 107   else
 108     {
 109       EMACS_INT i, i_byte, size = SCHARS (obj);
 110       int len;
 111       USE_SAFE_ALLOCA;
 112       unsigned char *dst, *o;
 113       /* Over-allocate by 12%: this is a minor overhead, but should be
 114          sufficient in 99.999% of the cases to avoid a reallocation.  */
 115       EMACS_INT o_size = SBYTES (obj) + SBYTES (obj) / 8 + MAX_MULTIBYTE_LENGTH;
 116       SAFE_ALLOCA (dst, void *, o_size);
 117       o = dst;
 118
 119       for (i = i_byte = 0; i < size; i++, i_byte += len)
 120         {
 121           if ((o - dst) + MAX_MULTIBYTE_LENGTH > o_size)
 122             { /* Not enough space for the next char: grow the destination.  */
 123               unsigned char *old_dst = dst;
 124               o_size += o_size; /* Probably overkill, but extremely rare.  */
 125               SAFE_ALLOCA (dst, void *, o_size);
 126               bcopy (old_dst, dst, o - old_dst);
 127               o = dst + (o - old_dst);
 128             }
 129           c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, 0, 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 (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      (obj)
 152      Lisp_Object obj;
 153 {
 154   return casify_object (CASE_UP, obj);
 155 }
 156
 157 DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
 158        doc: /* Convert argument to lower case and return that.
 159 The argument may be a character or string.  The result has the same type.
 160 The argument object is not altered--the value is a copy.  */)
 161      (obj)
 162      Lisp_Object obj;
 163 {
 164   return casify_object (CASE_DOWN, obj);
 165 }
 166
 167 DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
 168        doc: /* Convert argument to capitalized form and return that.
 169 This means that each word's first character is upper case
 170 and the rest is lower case.
 171 The argument may be a character or string.  The result has the same type.
 172 The argument object is not altered--the value is a copy.  */)
 173      (obj)
 174      Lisp_Object obj;
 175 {
 176   return casify_object (CASE_CAPITALIZE, obj);
 177 }
 178
 179 /* Like Fcapitalize but change only the initials.  */
 180
 181 DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0,
 182        doc: /* Convert the initial of each word in the argument to upper case.
 183 Do not change the other letters of each word.
 184 The argument may be a character or string.  The result has the same type.
 185 The argument object is not altered--the value is a copy.  */)
 186      (obj)
 187      Lisp_Object obj;
 188 {
 189   return casify_object (CASE_CAPITALIZE_UP, obj);
 190 }
 191 \f
 192 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
 193    b and e specify range of buffer to operate on. */
 194
 195 void
 196 casify_region (flag, b, e)
 197      enum case_action flag;
 198      Lisp_Object b, e;
 199 {
 200   register int c;
 201   register int inword = flag == CASE_DOWN;
 202   register int multibyte = !NILP (current_buffer->enable_multibyte_characters);
 203   EMACS_INT start, end;
 204   EMACS_INT start_byte, end_byte;
 205   EMACS_INT first = -1, last;   /* Position of first and last changes.  */
 206   EMACS_INT opoint = PT;
 207   EMACS_INT opoint_byte = PT_BYTE;
 208
 209   if (EQ (b, e))
 210     /* Not modifying because nothing marked */
 211     return;
 212
 213   /* If the case table is flagged as modified, rescan it.  */
 214   if (NILP (XCHAR_TABLE (current_buffer->downcase_table)->extras[1]))
 215     Fset_case_table (current_buffer->downcase_table);
 216
 217   validate_region (&b, &e);
 218   start = XFASTINT (b);
 219   end = XFASTINT (e);
 220   modify_region (current_buffer, start, end, 0);
 221   record_change (start, end - start);
 222   start_byte = CHAR_TO_BYTE (start);
 223   end_byte = CHAR_TO_BYTE (end);
 224
 225   while (start < end)
 226     {
 227       int c2, len;
 228
 229       if (multibyte)
 230         {
 231           c = FETCH_MULTIBYTE_CHAR (start_byte);
 232           len = CHAR_BYTES (c);
 233         }
 234       else
 235         {
 236           c = FETCH_BYTE (start_byte);
 237           MAKE_CHAR_MULTIBYTE (c);
 238           len = 1;
 239         }
 240       c2 = c;
 241       if (inword && flag != CASE_CAPITALIZE_UP)
 242         c = DOWNCASE (c);
 243       else if (!UPPERCASEP (c)
 244                && (!inword || flag != CASE_CAPITALIZE_UP))
 245         c = UPCASE1 (c);
 246       if ((int) flag >= (int) CASE_CAPITALIZE)
 247         inword = ((SYNTAX (c) == Sword) && (inword || !SYNTAX_PREFIX (c)));
 248       if (c != c2)
 249         {
 250           last = start;
 251           if (first < 0)
 252             first = start;
 253
 254           if (! multibyte)
 255             {
 256               MAKE_CHAR_UNIBYTE (c);
 257               FETCH_BYTE (start_byte) = c;
 258             }
 259           else if (ASCII_CHAR_P (c2) && ASCII_CHAR_P (c))
 260             FETCH_BYTE (start_byte) = c;
 261           else
 262             {
 263               int tolen = CHAR_BYTES (c);
 264               int j;
 265               unsigned char str[MAX_MULTIBYTE_LENGTH];
 266
 267               CHAR_STRING (c, str);
 268               if (len == tolen)
 269                 {
 270                   /* Length is unchanged.  */
 271                   for (j = 0; j < len; ++j)
 272                     FETCH_BYTE (start_byte + j) = str[j];
 273                 }
 274               else
 275                 {
 276                   /* Replace one character with the other,
 277                      keeping text properties the same.  */
 278                   replace_range_2 (start, start_byte,
 279                                    start + 1, start_byte + len,
 280                                    str, 1, tolen,
 281                                    0);
 282                   len = tolen;
 283                 }
 284             }
 285         }
 286       start++;
 287       start_byte += len;
 288     }
 289
 290   if (PT != opoint)
 291     TEMP_SET_PT_BOTH (opoint, opoint_byte);
 292
 293   if (first >= 0)
 294     {
 295       signal_after_change (first, last + 1 - first, last + 1 - first);
 296       update_compositions (first, last + 1, CHECK_ALL);
 297     }
 298 }
 299
 300 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
 301        doc: /* Convert the region to upper case.  In programs, wants two arguments.
 302 These arguments specify the starting and ending character numbers of
 303 the region to operate on.  When used as a command, the text between
 304 point and the mark is operated on.
 305 See also `capitalize-region'.  */)
 306      (beg, end)
 307      Lisp_Object beg, end;
 308 {
 309   casify_region (CASE_UP, beg, end);
 310   return Qnil;
 311 }
 312
 313 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
 314        doc: /* Convert the region to lower case.  In programs, wants two arguments.
 315 These arguments specify the starting and ending character numbers of
 316 the region to operate on.  When used as a command, the text between
 317 point and the mark is operated on.  */)
 318      (beg, end)
 319      Lisp_Object beg, 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      (beg, end)
 332      Lisp_Object beg, end;
 333 {
 334   casify_region (CASE_CAPITALIZE, beg, end);
 335   return Qnil;
 336 }
 337
 338 /* Like Fcapitalize_region but change only the initials.  */
 339
 340 DEFUN ("upcase-initials-region", Fupcase_initials_region,
 341        Supcase_initials_region, 2, 2, "r",
 342        doc: /* Upcase the initial of each word in the region.
 343 Subsequent letters of each word are not changed.
 344 In programs, give two arguments, the starting and ending
 345 character positions to operate on.  */)
 346      (beg, end)
 347      Lisp_Object beg, end;
 348 {
 349   casify_region (CASE_CAPITALIZE_UP, beg, end);
 350   return Qnil;
 351 }
 352 \f
 353 static Lisp_Object
 354 operate_on_word (arg, newpoint)
 355      Lisp_Object arg;
 356      EMACS_INT *newpoint;
 357 {
 358   Lisp_Object val;
 359   int farend;
 360   int iarg;
 361
 362   CHECK_NUMBER (arg);
 363   iarg = XINT (arg);
 364   farend = scan_words (PT, iarg);
 365   if (!farend)
 366     farend = iarg > 0 ? ZV : BEGV;
 367
 368   *newpoint = PT > farend ? PT : farend;
 369   XSETFASTINT (val, farend);
 370
 371   return val;
 372 }
 373
 374 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
 375        doc: /* Convert following word (or ARG words) to upper case, moving over.
 376 With negative argument, convert previous words but do not move.
 377 See also `capitalize-word'.  */)
 378      (arg)
 379      Lisp_Object arg;
 380 {
 381   Lisp_Object beg, end;
 382   EMACS_INT newpoint;
 383   XSETFASTINT (beg, PT);
 384   end = operate_on_word (arg, &newpoint);
 385   casify_region (CASE_UP, beg, end);
 386   SET_PT (newpoint);
 387   return Qnil;
 388 }
 389
 390 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 391        doc: /* Convert following word (or ARG words) to lower case, moving over.
 392 With negative argument, convert previous words but do not move.  */)
 393      (arg)
 394      Lisp_Object arg;
 395 {
 396   Lisp_Object beg, end;
 397   EMACS_INT newpoint;
 398   XSETFASTINT (beg, PT);
 399   end = operate_on_word (arg, &newpoint);
 400   casify_region (CASE_DOWN, beg, end);
 401   SET_PT (newpoint);
 402   return Qnil;
 403 }
 404
 405 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 406        doc: /* Capitalize the following word (or ARG words), moving over.
 407 This gives the word(s) a first character in upper case
 408 and the rest lower case.
 409 With negative argument, capitalize previous words but do not move.  */)
 410      (arg)
 411      Lisp_Object arg;
 412 {
 413   Lisp_Object beg, end;
 414   EMACS_INT newpoint;
 415   XSETFASTINT (beg, PT);
 416   end = operate_on_word (arg, &newpoint);
 417   casify_region (CASE_CAPITALIZE, beg, end);
 418   SET_PT (newpoint);
 419   return Qnil;
 420 }
 421 \f
 422 void
 423 syms_of_casefiddle ()
 424 {
 425   Qidentity = intern ("identity");
 426   staticpro (&Qidentity);
 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 ()
 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 }
 452
 453 /* arch-tag: 60a73c66-5489-47e7-a81f-cead4057c526
 454    (do not change this comment) */