code.delx.au - gnu-emacs/blob - src/casefiddle.c

   1 /* GNU Emacs case conversion functions.
   2    Copyright (C) 1985, 1994, 1997, 1998, 1999, 2001, 2002, 2003, 2004,
   3                  2005, 2006 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 2, or (at your option)
  10 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; see the file COPYING.  If not, write to
  19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  20 Boston, MA 02110-1301, USA.  */
  21
  22
  23 #include <config.h>
  24 #include "lisp.h"
  25 #include "buffer.h"
  26 #include "charset.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 Lisp_Object
  37 casify_object (flag, obj)
  38      enum case_action flag;
  39      Lisp_Object obj;
  40 {
  41   register int i, c, len;
  42   register int inword = flag == CASE_DOWN;
  43
  44   /* If the case table is flagged as modified, rescan it.  */
  45   if (NILP (XCHAR_TABLE (current_buffer->downcase_table)->extras[1]))
  46     Fset_case_table (current_buffer->downcase_table);
  47
  48   while (1)
  49     {
  50       if (INTEGERP (obj))
  51         {
  52           int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
  53                           | CHAR_SHIFT | CHAR_CTL | CHAR_META);
  54           int flags = XINT (obj) & flagbits;
  55
  56           /* If the character has higher bits set
  57              above the flags, return it unchanged.
  58              It is not a real character.  */
  59           if ((unsigned) XFASTINT (obj) > (unsigned) flagbits)
  60             return obj;
  61
  62           c = DOWNCASE (XFASTINT (obj) & ~flagbits);
  63           if (inword)
  64             XSETFASTINT (obj, c | flags);
  65           else if (c == (XFASTINT (obj) & ~flagbits))
  66             {
  67               c = UPCASE1 ((XFASTINT (obj) & ~flagbits));
  68               XSETFASTINT (obj, c | flags);
  69             }
  70           return obj;
  71         }
  72
  73       if (STRINGP (obj))
  74         {
  75           int multibyte = STRING_MULTIBYTE (obj);
  76           int n;
  77
  78           obj = Fcopy_sequence (obj);
  79           len = SBYTES (obj);
  80
  81           /* I counts bytes, and N counts chars.  */
  82           for (i = n = 0; i < len; n++)
  83             {
  84               int from_len = 1, to_len = 1;
  85
  86               c = SREF (obj, i);
  87
  88               if (multibyte && c >= 0x80)
  89                 c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i, len -i, from_len);
  90               if (inword && flag != CASE_CAPITALIZE_UP)
  91                 c = DOWNCASE (c);
  92               else if (!UPPERCASEP (c)
  93                        && (!inword || flag != CASE_CAPITALIZE_UP))
  94                 c = UPCASE1 (c);
  95               if ((ASCII_BYTE_P (c) && from_len == 1)
  96                   || (! multibyte && SINGLE_BYTE_CHAR_P (c)))
  97                 SSET (obj, i, c);
  98               else
  99                 {
 100                   to_len = CHAR_BYTES (c);
 101                   if (from_len == to_len)
 102                     CHAR_STRING (c, SDATA (obj) + i);
 103                   else
 104                     {
 105                       Faset (obj, make_number (n), make_number (c));
 106                       len += to_len - from_len;
 107                     }
 108                 }
 109               if ((int) flag >= (int) CASE_CAPITALIZE)
 110                 inword = SYNTAX (c) == Sword;
 111               i += to_len;
 112             }
 113           return obj;
 114         }
 115       obj = wrong_type_argument (Qchar_or_string_p, obj);
 116     }
 117 }
 118
 119 DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
 120        doc: /* Convert argument to upper case and return that.
 121 The argument may be a character or string.  The result has the same type.
 122 The argument object is not altered--the value is a copy.
 123 See also `capitalize', `downcase' and `upcase-initials'.  */)
 124      (obj)
 125      Lisp_Object obj;
 126 {
 127   return casify_object (CASE_UP, obj);
 128 }
 129
 130 DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
 131        doc: /* Convert argument to lower case and return that.
 132 The argument may be a character or string.  The result has the same type.
 133 The argument object is not altered--the value is a copy.  */)
 134      (obj)
 135      Lisp_Object obj;
 136 {
 137   return casify_object (CASE_DOWN, obj);
 138 }
 139
 140 DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
 141        doc: /* Convert argument to capitalized form and return that.
 142 This means that each word's first character is upper case
 143 and the rest is lower case.
 144 The argument may be a character or string.  The result has the same type.
 145 The argument object is not altered--the value is a copy.  */)
 146      (obj)
 147      Lisp_Object obj;
 148 {
 149   return casify_object (CASE_CAPITALIZE, obj);
 150 }
 151
 152 /* Like Fcapitalize but change only the initials.  */
 153
 154 DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0,
 155        doc: /* Convert the initial of each word in the argument to upper case.
 156 Do not change the other letters of each word.
 157 The argument may be a character or string.  The result has the same type.
 158 The argument object is not altered--the value is a copy.  */)
 159      (obj)
 160      Lisp_Object obj;
 161 {
 162   return casify_object (CASE_CAPITALIZE_UP, obj);
 163 }
 164 \f
 165 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
 166    b and e specify range of buffer to operate on. */
 167
 168 void
 169 casify_region (flag, b, e)
 170      enum case_action flag;
 171      Lisp_Object b, e;
 172 {
 173   register int i;
 174   register int c;
 175   register int inword = flag == CASE_DOWN;
 176   register int multibyte = !NILP (current_buffer->enable_multibyte_characters);
 177   int start, end;
 178   int start_byte, end_byte;
 179   int changed = 0;
 180
 181   if (EQ (b, e))
 182     /* Not modifying because nothing marked */
 183     return;
 184
 185   /* If the case table is flagged as modified, rescan it.  */
 186   if (NILP (XCHAR_TABLE (current_buffer->downcase_table)->extras[1]))
 187     Fset_case_table (current_buffer->downcase_table);
 188
 189   validate_region (&b, &e);
 190   start = XFASTINT (b);
 191   end = XFASTINT (e);
 192   modify_region (current_buffer, start, end);
 193   record_change (start, end - start);
 194   start_byte = CHAR_TO_BYTE (start);
 195   end_byte = CHAR_TO_BYTE (end);
 196
 197   for (i = start_byte; i < end_byte; i++, start++)
 198     {
 199       int c2;
 200       c = c2 = FETCH_BYTE (i);
 201       if (multibyte && c >= 0x80)
 202         /* A multibyte character can't be handled in this simple loop.  */
 203         break;
 204       if (inword && flag != CASE_CAPITALIZE_UP)
 205         c = DOWNCASE (c);
 206       else if (!UPPERCASEP (c)
 207                && (!inword || flag != CASE_CAPITALIZE_UP))
 208         c = UPCASE1 (c);
 209       if (multibyte && c >= 0x80)
 210         /* A multibyte result character can't be handled in this
 211            simple loop.  */
 212         break;
 213       FETCH_BYTE (i) = c;
 214       if (c != c2)
 215         changed = 1;
 216       if ((int) flag >= (int) CASE_CAPITALIZE)
 217         inword = SYNTAX (c) == Sword && (inword || !SYNTAX_PREFIX (c));
 218     }
 219   if (i < end_byte)
 220     {
 221       /* The work is not yet finished because of a multibyte character
 222          just encountered.  */
 223       int opoint = PT;
 224       int opoint_byte = PT_BYTE;
 225       int c2;
 226
 227       while (start < end)
 228         {
 229           if ((c = FETCH_BYTE (i)) >= 0x80)
 230             c = FETCH_MULTIBYTE_CHAR (i);
 231           c2 = c;
 232           if (inword && flag != CASE_CAPITALIZE_UP)
 233             c2 = DOWNCASE (c);
 234           else if (!UPPERCASEP (c)
 235                    && (!inword || flag != CASE_CAPITALIZE_UP))
 236             c2 = UPCASE1 (c);
 237           if (c != c2)
 238             {
 239               int fromlen, tolen, j;
 240               unsigned char str[MAX_MULTIBYTE_LENGTH];
 241
 242               changed = 1;
 243               /* Handle the most likely case */
 244               if (c < 0400 && c2 < 0400)
 245                 FETCH_BYTE (i) = c2;
 246               else if (fromlen = CHAR_STRING (c, str),
 247                        tolen = CHAR_STRING (c2, str),
 248                        fromlen == tolen)
 249                 {
 250                   /* Length is unchanged.  */
 251                   for (j = 0; j < tolen; ++j)
 252                     FETCH_BYTE (i + j) = str[j];
 253                 }
 254               else
 255                 {
 256                   /* Replace one character with the other,
 257                      keeping text properties the same.  */
 258                   replace_range_2 (start, i,
 259                                    start + 1, i + fromlen,
 260                                    str, 1, tolen,
 261                                    1);
 262                   if (opoint > start)
 263                     opoint_byte += tolen - fromlen;
 264                 }
 265             }
 266           if ((int) flag >= (int) CASE_CAPITALIZE)
 267             inword = SYNTAX (c2) == Sword;
 268           INC_BOTH (start, i);
 269         }
 270       TEMP_SET_PT_BOTH (opoint, opoint_byte);
 271     }
 272
 273   start = XFASTINT (b);
 274   if (changed)
 275     {
 276       signal_after_change (start, end - start, end - start);
 277       update_compositions (start, end, CHECK_ALL);
 278     }
 279 }
 280
 281 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
 282        doc: /* Convert the region to upper case.  In programs, wants two arguments.
 283 These arguments specify the starting and ending character numbers of
 284 the region to operate on.  When used as a command, the text between
 285 point and the mark is operated on.
 286 See also `capitalize-region'.  */)
 287      (beg, end)
 288      Lisp_Object beg, end;
 289 {
 290   casify_region (CASE_UP, beg, end);
 291   return Qnil;
 292 }
 293
 294 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
 295        doc: /* Convert the region to lower case.  In programs, wants two arguments.
 296 These arguments specify the starting and ending character numbers of
 297 the region to operate on.  When used as a command, the text between
 298 point and the mark is operated on.  */)
 299      (beg, end)
 300      Lisp_Object beg, end;
 301 {
 302   casify_region (CASE_DOWN, beg, end);
 303   return Qnil;
 304 }
 305
 306 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
 307        doc: /* Convert the region to capitalized form.
 308 Capitalized form means each word's first character is upper case
 309 and the rest of it is lower case.
 310 In programs, give two arguments, the starting and ending
 311 character positions to operate on.  */)
 312      (beg, end)
 313      Lisp_Object beg, end;
 314 {
 315   casify_region (CASE_CAPITALIZE, beg, end);
 316   return Qnil;
 317 }
 318
 319 /* Like Fcapitalize_region but change only the initials.  */
 320
 321 DEFUN ("upcase-initials-region", Fupcase_initials_region,
 322        Supcase_initials_region, 2, 2, "r",
 323        doc: /* Upcase the initial of each word in the region.
 324 Subsequent letters of each word are not changed.
 325 In programs, give two arguments, the starting and ending
 326 character positions to operate on.  */)
 327      (beg, end)
 328      Lisp_Object beg, end;
 329 {
 330   casify_region (CASE_CAPITALIZE_UP, beg, end);
 331   return Qnil;
 332 }
 333 \f
 334 Lisp_Object
 335 operate_on_word (arg, newpoint)
 336      Lisp_Object arg;
 337      int *newpoint;
 338 {
 339   Lisp_Object val;
 340   int farend;
 341   int iarg;
 342
 343   CHECK_NUMBER (arg);
 344   iarg = XINT (arg);
 345   farend = scan_words (PT, iarg);
 346   if (!farend)
 347     farend = iarg > 0 ? ZV : BEGV;
 348
 349   *newpoint = PT > farend ? PT : farend;
 350   XSETFASTINT (val, farend);
 351
 352   return val;
 353 }
 354
 355 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
 356        doc: /* Convert following word (or ARG words) to upper case, moving over.
 357 With negative argument, convert previous words but do not move.
 358 See also `capitalize-word'.  */)
 359      (arg)
 360      Lisp_Object arg;
 361 {
 362   Lisp_Object beg, end;
 363   int newpoint;
 364   XSETFASTINT (beg, PT);
 365   end = operate_on_word (arg, &newpoint);
 366   casify_region (CASE_UP, beg, end);
 367   SET_PT (newpoint);
 368   return Qnil;
 369 }
 370
 371 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 372        doc: /* Convert following word (or ARG words) to lower case, moving over.
 373 With negative argument, convert previous words but do not move.  */)
 374      (arg)
 375      Lisp_Object arg;
 376 {
 377   Lisp_Object beg, end;
 378   int newpoint;
 379   XSETFASTINT (beg, PT);
 380   end = operate_on_word (arg, &newpoint);
 381   casify_region (CASE_DOWN, beg, end);
 382   SET_PT (newpoint);
 383   return Qnil;
 384 }
 385
 386 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 387        doc: /* Capitalize the following word (or ARG words), moving over.
 388 This gives the word(s) a first character in upper case
 389 and the rest lower case.
 390 With negative argument, capitalize previous words but do not move.  */)
 391      (arg)
 392      Lisp_Object arg;
 393 {
 394   Lisp_Object beg, end;
 395   int newpoint;
 396   XSETFASTINT (beg, PT);
 397   end = operate_on_word (arg, &newpoint);
 398   casify_region (CASE_CAPITALIZE, beg, end);
 399   SET_PT (newpoint);
 400   return Qnil;
 401 }
 402 \f
 403 void
 404 syms_of_casefiddle ()
 405 {
 406   Qidentity = intern ("identity");
 407   staticpro (&Qidentity);
 408   defsubr (&Supcase);
 409   defsubr (&Sdowncase);
 410   defsubr (&Scapitalize);
 411   defsubr (&Supcase_initials);
 412   defsubr (&Supcase_region);
 413   defsubr (&Sdowncase_region);
 414   defsubr (&Scapitalize_region);
 415   defsubr (&Supcase_initials_region);
 416   defsubr (&Supcase_word);
 417   defsubr (&Sdowncase_word);
 418   defsubr (&Scapitalize_word);
 419 }
 420
 421 void
 422 keys_of_casefiddle ()
 423 {
 424   initial_define_key (control_x_map, Ctl('U'), "upcase-region");
 425   Fput (intern ("upcase-region"), Qdisabled, Qt);
 426   initial_define_key (control_x_map, Ctl('L'), "downcase-region");
 427   Fput (intern ("downcase-region"), Qdisabled, Qt);
 428
 429   initial_define_key (meta_map, 'u', "upcase-word");
 430   initial_define_key (meta_map, 'l', "downcase-word");
 431   initial_define_key (meta_map, 'c', "capitalize-word");
 432 }
 433
 434 /* arch-tag: 60a73c66-5489-47e7-a81f-cead4057c526
 435    (do not change this comment) */