src/casefiddle.c

   1 /* GNU Emacs case conversion functions.
   2    Copyright (C) 1985,94,97,98,99, 2001, 2002, 2004
   3    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., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, 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
  77           obj = Fcopy_sequence (obj);
  78           len = SBYTES (obj);
  79
  80           /* Scan all single-byte characters from start of string.  */
  81           for (i = 0; i < len;)
  82             {
  83               c = SREF (obj, i);
  84
  85               if (multibyte && c >= 0x80)
  86                 /* A multibyte character can't be handled in this
  87                    simple loop.  */
  88                 break;
  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 (c);
  94               /* If this char won't fit in a single-byte string.
  95                  fall out to the multibyte case.  */
  96               if (multibyte ? ! ASCII_BYTE_P (c)
  97                   : ! SINGLE_BYTE_CHAR_P (c))
  98                 break;
  99
 100               SSET (obj, i, c);
 101               if ((int) flag >= (int) CASE_CAPITALIZE)
 102                 inword = SYNTAX (c) == Sword;
 103               i++;
 104             }
 105
 106           /* If we didn't do the whole string as single-byte,
 107              scan the rest in a more complex way.  */
 108           if (i < len)
 109             {
 110               /* The work is not yet finished because of a multibyte
 111                  character just encountered.  */
 112               int fromlen, j_byte = i;
 113               char *buf;
 114               int bufsize;
 115               USE_SAFE_ALLOCA;
 116
 117               bufsize = (len - i) * MAX_MULTIBYTE_LENGTH + i;
 118               SAFE_ALLOCA (buf, char *, bufsize);
 119
 120               /* Copy data already handled.  */
 121               bcopy (SDATA (obj), buf, i);
 122
 123               /* From now on, I counts bytes.  */
 124               while (i < len)
 125                 {
 126                   c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i,
 127                                               len - i, fromlen);
 128                   if (inword && flag != CASE_CAPITALIZE_UP)
 129                     c = DOWNCASE (c);
 130                   else if (!UPPERCASEP (c)
 131                            && (!inword || flag != CASE_CAPITALIZE_UP))
 132                     c = UPCASE1 (c);
 133                   i += fromlen;
 134                   j_byte += CHAR_STRING (c, buf + j_byte);
 135                   if ((int) flag >= (int) CASE_CAPITALIZE)
 136                     inword = SYNTAX (c) == Sword;
 137                 }
 138               obj = make_multibyte_string (buf, SCHARS (obj),
 139                                            j_byte);
 140               SAFE_FREE ();
 141             }
 142           return obj;
 143         }
 144       obj = wrong_type_argument (Qchar_or_string_p, obj);
 145     }
 146 }
 147
 148 DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
 149        doc: /* Convert argument to upper case and return that.
 150 The argument may be a character or string.  The result has the same type.
 151 The argument object is not altered--the value is a copy.
 152 See also `capitalize', `downcase' and `upcase-initials'.  */)
 153      (obj)
 154      Lisp_Object obj;
 155 {
 156   return casify_object (CASE_UP, obj);
 157 }
 158
 159 DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
 160        doc: /* Convert argument to lower case and return that.
 161 The argument may be a character or string.  The result has the same type.
 162 The argument object is not altered--the value is a copy.  */)
 163      (obj)
 164      Lisp_Object obj;
 165 {
 166   return casify_object (CASE_DOWN, obj);
 167 }
 168
 169 DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
 170        doc: /* Convert argument to capitalized form and return that.
 171 This means that each word's first character is upper case
 172 and the rest is lower case.
 173 The argument may be a character or string.  The result has the same type.
 174 The argument object is not altered--the value is a copy.  */)
 175      (obj)
 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      (obj)
 189      Lisp_Object obj;
 190 {
 191   return casify_object (CASE_CAPITALIZE_UP, obj);
 192 }
 193 \f
 194 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
 195    b and e specify range of buffer to operate on. */
 196
 197 void
 198 casify_region (flag, b, e)
 199      enum case_action flag;
 200      Lisp_Object b, e;
 201 {
 202   register int i;
 203   register int c;
 204   register int inword = flag == CASE_DOWN;
 205   register int multibyte = !NILP (current_buffer->enable_multibyte_characters);
 206   int start, end;
 207   int start_byte, end_byte;
 208   int changed = 0;
 209
 210   if (EQ (b, e))
 211     /* Not modifying because nothing marked */
 212     return;
 213
 214   /* If the case table is flagged as modified, rescan it.  */
 215   if (NILP (XCHAR_TABLE (current_buffer->downcase_table)->extras[1]))
 216     Fset_case_table (current_buffer->downcase_table);
 217
 218   validate_region (&b, &e);
 219   start = XFASTINT (b);
 220   end = XFASTINT (e);
 221   modify_region (current_buffer, start, end);
 222   record_change (start, end - start);
 223   start_byte = CHAR_TO_BYTE (start);
 224   end_byte = CHAR_TO_BYTE (end);
 225
 226   for (i = start_byte; i < end_byte; i++, start++)
 227     {
 228       int c2;
 229       c = c2 = FETCH_BYTE (i);
 230       if (multibyte && c >= 0x80)
 231         /* A multibyte character can't be handled in this simple loop.  */
 232         break;
 233       if (inword && flag != CASE_CAPITALIZE_UP)
 234         c = DOWNCASE (c);
 235       else if (!UPPERCASEP (c)
 236                && (!inword || flag != CASE_CAPITALIZE_UP))
 237         c = UPCASE1 (c);
 238       if (multibyte && c >= 0x80)
 239         /* A multibyte result character can't be handled in this
 240            simple loop.  */
 241         break;
 242       FETCH_BYTE (i) = c;
 243       if (c != c2)
 244         changed = 1;
 245       if ((int) flag >= (int) CASE_CAPITALIZE)
 246         inword = SYNTAX (c) == Sword && (inword || !SYNTAX_PREFIX (c));
 247     }
 248   if (i < end_byte)
 249     {
 250       /* The work is not yet finished because of a multibyte character
 251          just encountered.  */
 252       int opoint = PT;
 253       int opoint_byte = PT_BYTE;
 254       int c2;
 255
 256       while (i < end_byte)
 257         {
 258           if ((c = FETCH_BYTE (i)) >= 0x80)
 259             c = FETCH_MULTIBYTE_CHAR (i);
 260           c2 = c;
 261           if (inword && flag != CASE_CAPITALIZE_UP)
 262             c2 = DOWNCASE (c);
 263           else if (!UPPERCASEP (c)
 264                    && (!inword || flag != CASE_CAPITALIZE_UP))
 265             c2 = UPCASE1 (c);
 266           if (c != c2)
 267             {
 268               int fromlen, tolen, j;
 269               unsigned char str[MAX_MULTIBYTE_LENGTH];
 270
 271               changed = 1;
 272               /* Handle the most likely case */
 273               if (c < 0400 && c2 < 0400)
 274                 FETCH_BYTE (i) = c2;
 275               else if (fromlen = CHAR_STRING (c, str),
 276                        tolen = CHAR_STRING (c2, str),
 277                        fromlen == tolen)
 278                 {
 279                   /* Length is unchanged.  */
 280                   for (j = 0; j < tolen; ++j)
 281                     FETCH_BYTE (i + j) = str[j];
 282                 }
 283               else
 284                 /* Replace one character with the other,
 285                    keeping text properties the same.  */
 286                 replace_range_2 (start + 1, i + tolen,
 287                                  start + 2, i + tolen + fromlen,
 288                                  str, 1, tolen,
 289                                  0);
 290             }
 291           if ((int) flag >= (int) CASE_CAPITALIZE)
 292             inword = SYNTAX (c2) == Sword;
 293           INC_BOTH (start, i);
 294         }
 295       TEMP_SET_PT_BOTH (opoint, opoint_byte);
 296     }
 297
 298   start = XFASTINT (b);
 299   if (changed)
 300     {
 301       signal_after_change (start, end - start, end - start);
 302       update_compositions (start, end, 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 Lisp_Object
 360 operate_on_word (arg, newpoint)
 361      Lisp_Object arg;
 362      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   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   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   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) */