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