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

   1 /* GNU Emacs case conversion functions.
   2    Copyright (C) 1985, 1994 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           c = DOWNCASE (XFASTINT (obj));
  51           if (inword)
  52             XSETFASTINT (obj, c);
  53           else if (c == XFASTINT (obj))
  54             {
  55               c = UPCASE1 (XFASTINT (obj));
  56               XSETFASTINT (obj, c);
  57             }
  58           return obj;
  59         }
  60       if (STRINGP (obj))
  61         {
  62           int multibyte = !NILP (current_buffer->enable_multibyte_characters);
  63
  64           obj = Fcopy_sequence (obj);
  65           len = XSTRING (obj)->size;
  66           for (i = 0; i < len; i++)
  67             {
  68               c = XSTRING (obj)->data[i];
  69               if (multibyte && c >= 0x80)
  70                 /* A multibyte character can't be handled in this
  71                    simple loop.  */
  72                 break;
  73               if (inword && flag != CASE_CAPITALIZE_UP)
  74                 c = DOWNCASE (c);
  75               else if (!UPPERCASEP (c)
  76                        && (!inword || flag != CASE_CAPITALIZE_UP))
  77                 c = UPCASE1 (c);
  78               XSTRING (obj)->data[i] = c;
  79               if ((int) flag >= (int) CASE_CAPITALIZE)
  80                 inword = SYNTAX (c) == Sword;
  81             }
  82           if (i < len)
  83             {
  84               /* The work is not yet finished because of a multibyte
  85                  character just encountered.  */
  86               int fromlen, tolen, j = i;
  87               char *buf
  88                 = (char *) alloca ((len - i) * MAX_LENGTH_OF_MULTI_BYTE_FORM
  89                                    + i);
  90               unsigned char *str, workbuf[4];
  91
  92               /* Copy data already handled.  */
  93               bcopy (XSTRING (obj)->data, buf, i);
  94
  95               while (i < len)
  96                 {
  97                   c = STRING_CHAR_AND_LENGTH (XSTRING (obj)->data + i,
  98                                               len - i, fromlen);
  99                   if (inword && flag != CASE_CAPITALIZE_UP)
 100                     c = DOWNCASE (c);
 101                   else if (!UPPERCASEP (c)
 102                            && (!inword || flag != CASE_CAPITALIZE_UP))
 103                     c = UPCASE1 (c);
 104                   tolen = CHAR_STRING (c, workbuf, str);
 105                   bcopy (str, buf + j, tolen);
 106                   i += fromlen;
 107                   j += tolen;
 108                   if ((int) flag >= (int) CASE_CAPITALIZE)
 109                     inword = SYNTAX (c) == Sword;
 110                 }
 111               obj = make_string (buf, j);
 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   "Convert argument to upper case and return that.\n\
 121 The argument may be a character or string.  The result has the same type.\n\
 122 The argument object is not altered--the value is a copy.\n\
 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   "Convert argument to lower case and return that.\n\
 132 The argument may be a character or string.  The result has the same type.\n\
 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   "Convert argument to capitalized form and return that.\n\
 142 This means that each word's first character is upper case\n\
 143 and the rest is lower case.\n\
 144 The argument may be a character or string.  The result has the same type.\n\
 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   "Convert the initial of each word in the argument to upper case.\n\
 156 Do not change the other letters of each word.\n\
 157 The argument may be a character or string.  The result has the same type.\n\
 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 casify_region (flag, b, e)
 169      enum case_action flag;
 170      Lisp_Object b, e;
 171 {
 172   register int i;
 173   register int c;
 174   register int inword = flag == CASE_DOWN;
 175   register int multibyte = !NILP (current_buffer->enable_multibyte_characters);
 176   int start, end;
 177   int start_byte, end_byte;
 178   Lisp_Object ch, downch, val;
 179
 180   if (EQ (b, e))
 181     /* Not modifying because nothing marked */
 182     return;
 183
 184   /* If the case table is flagged as modified, rescan it.  */
 185   if (NILP (XCHAR_TABLE (current_buffer->downcase_table)->extras[1]))
 186     Fset_case_table (current_buffer->downcase_table);
 187
 188   validate_region (&b, &e);
 189   start = XFASTINT (b);
 190   end = XFASTINT (e);
 191   modify_region (current_buffer, start, end);
 192   record_change (start, end - start);
 193   start_byte = CHAR_TO_BYTE (start);
 194   end_byte = CHAR_TO_BYTE (end);
 195
 196   for (i = start_byte; i < end_byte; i++)
 197     {
 198       c = 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       FETCH_BYTE (i) = c;
 208       if ((int) flag >= (int) CASE_CAPITALIZE)
 209         inword = SYNTAX (c) == Sword;
 210     }
 211   if (i < end_byte)
 212     {
 213       /* The work is not yet finished because of a multibyte character
 214          just encountered.  */
 215       int opoint = PT;
 216       int opoint_byte = PT_BYTE;
 217       int c2;
 218
 219       while (i < end_byte)
 220         {
 221           if ((c = FETCH_BYTE (i)) >= 0x80)
 222             c = FETCH_MULTIBYTE_CHAR (i);
 223           c2 = c;
 224           if (inword && flag != CASE_CAPITALIZE_UP)
 225             c2 = DOWNCASE (c);
 226           else if (!UPPERCASEP (c)
 227                    && (!inword || flag != CASE_CAPITALIZE_UP))
 228             c2 = UPCASE1 (c);
 229           if (c != c2)
 230             {
 231               int fromlen, tolen, j;
 232               unsigned char workbuf[4], *str;
 233
 234               /* Handle the most likely case */
 235               if (c < 0400 && c2 < 0400)
 236                 FETCH_BYTE (i) = c2;
 237               else if (fromlen = CHAR_STRING (c, workbuf, str),
 238                        tolen = CHAR_STRING (c2, workbuf, str),
 239                        fromlen == tolen)
 240                 {
 241                   for (j = 0; j < tolen; ++j)
 242                     FETCH_BYTE (i + j) = str[j];
 243                 }
 244               else
 245                 {
 246                   error ("Can't casify letters that change length");
 247 #if 0 /* This is approximately what we'd like to be able to do here */
 248                   if (tolen < fromlen)
 249                     del_range_1 (i + tolen, i + fromlen, 0);
 250                   else if (tolen > fromlen)
 251                     {
 252                       TEMP_SET_PT (i + fromlen);
 253                       insert_1 (str + fromlen, tolen - fromlen, 1, 0, 0);
 254                     }
 255 #endif
 256                 }
 257             }
 258           if ((int) flag >= (int) CASE_CAPITALIZE)
 259             inword = SYNTAX (c2) == Sword;
 260           INC_POS (i);
 261         }
 262       TEMP_SET_PT_BOTH (opoint, opoint_byte);
 263     }
 264
 265   signal_after_change (start, end - start, end - start);
 266 }
 267
 268 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
 269   "Convert the region to upper case.  In programs, wants two arguments.\n\
 270 These arguments specify the starting and ending character numbers of\n\
 271 the region to operate on.  When used as a command, the text between\n\
 272 point and the mark is operated on.\n\
 273 See also `capitalize-region'.")
 274   (beg, end)
 275      Lisp_Object beg, end;
 276 {
 277   casify_region (CASE_UP, beg, end);
 278   return Qnil;
 279 }
 280
 281 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
 282   "Convert the region to lower case.  In programs, wants two arguments.\n\
 283 These arguments specify the starting and ending character numbers of\n\
 284 the region to operate on.  When used as a command, the text between\n\
 285 point and the mark is operated on.")
 286   (beg, end)
 287      Lisp_Object beg, end;
 288 {
 289   casify_region (CASE_DOWN, beg, end);
 290   return Qnil;
 291 }
 292
 293 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
 294   "Convert the region to capitalized form.\n\
 295 Capitalized form means each word's first character is upper case\n\
 296 and the rest of it is lower case.\n\
 297 In programs, give two arguments, the starting and ending\n\
 298 character positions to operate on.")
 299   (beg, end)
 300      Lisp_Object beg, end;
 301 {
 302   casify_region (CASE_CAPITALIZE, beg, end);
 303   return Qnil;
 304 }
 305
 306 /* Like Fcapitalize_region but change only the initials.  */
 307
 308 DEFUN ("upcase-initials-region", Fupcase_initials_region,
 309        Supcase_initials_region, 2, 2, "r",
 310   "Upcase the initial of each word in the region.\n\
 311 Subsequent letters of each word are not changed.\n\
 312 In programs, give two arguments, the starting and ending\n\
 313 character positions to operate on.")
 314   (beg, end)
 315      Lisp_Object beg, end;
 316 {
 317   casify_region (CASE_CAPITALIZE_UP, beg, end);
 318   return Qnil;
 319 }
 320 \f
 321 Lisp_Object
 322 operate_on_word (arg, newpoint)
 323      Lisp_Object arg;
 324      int *newpoint;
 325 {
 326   Lisp_Object val;
 327   int farend;
 328   int iarg;
 329
 330   CHECK_NUMBER (arg, 0);
 331   iarg = XINT (arg);
 332   farend = scan_words (PT, iarg);
 333   if (!farend)
 334     farend = iarg > 0 ? ZV : BEGV;
 335
 336   *newpoint = PT > farend ? PT : farend;
 337   XSETFASTINT (val, farend);
 338
 339   return val;
 340 }
 341
 342 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
 343   "Convert following word (or ARG words) to upper case, moving over.\n\
 344 With negative argument, convert previous words but do not move.\n\
 345 See also `capitalize-word'.")
 346   (arg)
 347      Lisp_Object arg;
 348 {
 349   Lisp_Object beg, end;
 350   int newpoint;
 351   XSETFASTINT (beg, PT);
 352   end = operate_on_word (arg, &newpoint);
 353   casify_region (CASE_UP, beg, end);
 354   SET_PT (newpoint);
 355   return Qnil;
 356 }
 357
 358 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 359   "Convert following word (or ARG words) to lower case, moving over.\n\
 360 With negative argument, convert previous words but do not move.")
 361   (arg)
 362      Lisp_Object arg;
 363 {
 364   Lisp_Object beg, end;
 365   int newpoint;
 366   XSETFASTINT (beg, PT);
 367   end = operate_on_word (arg, &newpoint);
 368   casify_region (CASE_DOWN, beg, end);
 369   SET_PT (newpoint);
 370   return Qnil;
 371 }
 372
 373 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 374   "Capitalize the following word (or ARG words), moving over.\n\
 375 This gives the word(s) a first character in upper case\n\
 376 and the rest lower case.\n\
 377 With negative argument, capitalize previous words but do not move.")
 378   (arg)
 379      Lisp_Object arg;
 380 {
 381   Lisp_Object beg, end;
 382   int newpoint;
 383   XSETFASTINT (beg, PT);
 384   end = operate_on_word (arg, &newpoint);
 385   casify_region (CASE_CAPITALIZE, beg, end);
 386   SET_PT (newpoint);
 387   return Qnil;
 388 }
 389 \f
 390 syms_of_casefiddle ()
 391 {
 392   Qidentity = intern ("identity");
 393   staticpro (&Qidentity);
 394   defsubr (&Supcase);
 395   defsubr (&Sdowncase);
 396   defsubr (&Scapitalize);
 397   defsubr (&Supcase_initials);
 398   defsubr (&Supcase_region);
 399   defsubr (&Sdowncase_region);
 400   defsubr (&Scapitalize_region);
 401   defsubr (&Supcase_initials_region);
 402   defsubr (&Supcase_word);
 403   defsubr (&Sdowncase_word);
 404   defsubr (&Scapitalize_word);
 405 }
 406
 407 keys_of_casefiddle ()
 408 {
 409   initial_define_key (control_x_map, Ctl('U'), "upcase-region");
 410   Fput (intern ("upcase-region"), Qdisabled, Qt);
 411   initial_define_key (control_x_map, Ctl('L'), "downcase-region");
 412   Fput (intern ("downcase-region"), Qdisabled, Qt);
 413
 414   initial_define_key (meta_map, 'u', "upcase-word");
 415   initial_define_key (meta_map, 'l', "downcase-word");
 416   initial_define_key (meta_map, 'c', "capitalize-word");
 417 }