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