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