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