src/casefiddle.c

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