src/casefiddle.c

   1 /* GNU Emacs case conversion functions.
   2    Copyright (C) 1985, 1994, 1997, 1998, 1999, 2001, 2002, 2003, 2004,
   3                  2005, 2006, 2007, 2008 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 3, 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., 51 Franklin Street, Fifth Floor,
  20 Boston, MA 02110-1301, USA.  */
  21
  22
  23 #include <config.h>
  24 #include "lisp.h"
  25 #include "buffer.h"
  26 #include "character.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 c, c1;
  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   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       int multibyte = ! NILP (current_buffer->enable_multibyte_characters);
  54
  55       /* If the character has higher bits set
  56          above the flags, return it unchanged.
  57          It is not a real character.  */
  58       if ((unsigned) XFASTINT (obj) > (unsigned) flagbits)
  59         return obj;
  60
  61       c1 = XFASTINT (obj) & ~flagbits;
  62       if (! multibyte)
  63         MAKE_CHAR_MULTIBYTE (c1);
  64       c = DOWNCASE (c1);
  65       if (inword)
  66         XSETFASTINT (obj, c | flags);
  67       else if (c == (XFASTINT (obj) & ~flagbits))
  68         {
  69           if (! inword)
  70             c = UPCASE1 (c1);
  71           if (! multibyte)
  72             MAKE_CHAR_UNIBYTE (c);
  73           XSETFASTINT (obj, c | flags);
  74         }
  75       return obj;
  76     }
  77
  78   if (!STRINGP (obj))
  79     wrong_type_argument (Qchar_or_string_p, obj);
  80   else if (!STRING_MULTIBYTE (obj))
  81     {
  82       EMACS_INT i;
  83       EMACS_INT size = SCHARS (obj);
  84
  85       obj = Fcopy_sequence (obj);
  86       for (i = 0; i < size; i++)
  87         {
  88           c = SREF (obj, i);
  89               MAKE_CHAR_MULTIBYTE (c);
  90           c1 = c;
  91           if (inword && flag != CASE_CAPITALIZE_UP)
  92             c = DOWNCASE (c);
  93           else if (!UPPERCASEP (c)
  94                    && (!inword || flag != CASE_CAPITALIZE_UP))
  95             c = UPCASE1 (c1);
  96           if ((int) flag >= (int) CASE_CAPITALIZE)
  97             inword = (SYNTAX (c) == Sword);
  98           if (c != c1)
  99             {
 100                   MAKE_CHAR_UNIBYTE (c);
 101               /* If the char can't be converted to a valid byte, just don't
 102                  change it.  */
 103               if (c >= 0 && c < 256)
 104                 SSET (obj, i, c);
 105             }
 106         }
 107       return obj;
 108                 }
 109               else
 110                 {
 111       EMACS_INT i, i_byte, len;
 112       EMACS_INT size = SCHARS (obj);
 113       USE_SAFE_ALLOCA;
 114       unsigned char *dst, *o;
 115       /* Over-allocate by 12%: this is a minor overhead, but should be
 116          sufficient in 99.999% of the cases to avoid a reallocation.  */
 117       EMACS_INT o_size = SBYTES (obj) + SBYTES (obj) / 8 + MAX_MULTIBYTE_LENGTH;
 118       SAFE_ALLOCA (dst, void *, o_size);
 119       o = dst;
 120
 121       for (i = i_byte = 0; i < size; i++, i_byte += len)
 122         {
 123           if ((o - dst) + MAX_MULTIBYTE_LENGTH > o_size)
 124             { /* Not enough space for the next char: grow the destination.  */
 125               unsigned char *old_dst = dst;
 126               o_size += o_size; /* Probably overkill, but extremely rare.  */
 127               SAFE_ALLOCA (dst, void *, o_size);
 128               bcopy (old_dst, dst, o - old_dst);
 129               o = dst + (o - old_dst);
 130             }
 131           c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, 0, len);
 132           if (inword && flag != CASE_CAPITALIZE_UP)
 133             c = DOWNCASE (c);
 134           else if (!UPPERCASEP (c)
 135                    && (!inword || flag != CASE_CAPITALIZE_UP))
 136             c = UPCASE1 (c);
 137           if ((int) flag >= (int) CASE_CAPITALIZE)
 138             inword = (SYNTAX (c) == Sword);
 139           o += CHAR_STRING (c, o);
 140         }
 141       eassert (o - dst <= o_size);
 142       obj = make_multibyte_string (dst, size, o - dst);
 143       SAFE_FREE ();
 144       return 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 c;
 203   register int inword = flag == CASE_DOWN;
 204   register int multibyte = !NILP (current_buffer->enable_multibyte_characters);
 205   EMACS_INT start, end;
 206   EMACS_INT start_byte, end_byte;
 207   EMACS_INT first = -1, last;   /* Position of first and last changes.  */
 208   EMACS_INT opoint = PT;
 209   EMACS_INT opoint_byte = PT_BYTE;
 210
 211   if (EQ (b, e))
 212     /* Not modifying because nothing marked */
 213     return;
 214
 215   /* If the case table is flagged as modified, rescan it.  */
 216   if (NILP (XCHAR_TABLE (current_buffer->downcase_table)->extras[1]))
 217     Fset_case_table (current_buffer->downcase_table);
 218
 219   validate_region (&b, &e);
 220   start = XFASTINT (b);
 221   end = XFASTINT (e);
 222   modify_region (current_buffer, start, end, 0);
 223   record_change (start, end - start);
 224   start_byte = CHAR_TO_BYTE (start);
 225   end_byte = CHAR_TO_BYTE (end);
 226
 227   while (start < end)
 228     {
 229       int c2, len;
 230
 231       if (multibyte)
 232         {
 233           c = FETCH_MULTIBYTE_CHAR (start_byte);
 234           len = CHAR_BYTES (c);
 235         }
 236       else
 237         {
 238           c = FETCH_BYTE (start_byte);
 239           MAKE_CHAR_MULTIBYTE (c);
 240           len = 1;
 241         }
 242       c2 = c;
 243       if (inword && flag != CASE_CAPITALIZE_UP)
 244         c = DOWNCASE (c);
 245       else if (!UPPERCASEP (c)
 246                && (!inword || flag != CASE_CAPITALIZE_UP))
 247         c = UPCASE1 (c);
 248       if ((int) flag >= (int) CASE_CAPITALIZE)
 249         inword = ((SYNTAX (c) == Sword) && (inword || !SYNTAX_PREFIX (c)));
 250       if (c != c2)
 251         {
 252           last = start;
 253           if (first < 0)
 254             first = start;
 255
 256           if (! multibyte)
 257             {
 258               MAKE_CHAR_UNIBYTE (c);
 259               FETCH_BYTE (start_byte) = c;
 260             }
 261           else if (ASCII_CHAR_P (c2) && ASCII_CHAR_P (c))
 262             FETCH_BYTE (start_byte) = c;
 263           else
 264             {
 265               int tolen = CHAR_BYTES (c);
 266               int j;
 267               unsigned char str[MAX_MULTIBYTE_LENGTH];
 268
 269               CHAR_STRING (c, str);
 270               if (len == tolen)
 271                 {
 272                   /* Length is unchanged.  */
 273                   for (j = 0; j < len; ++j)
 274                     FETCH_BYTE (start_byte + j) = str[j];
 275                 }
 276               else
 277                 {
 278                   /* Replace one character with the other,
 279                      keeping text properties the same.  */
 280                   replace_range_2 (start, start_byte,
 281                                    start + 1, start_byte + len,
 282                                    str, 1, tolen,
 283                                    0);
 284                   len = tolen;
 285                 }
 286             }
 287         }
 288       start++;
 289       start_byte += len;
 290     }
 291
 292   if (PT != opoint)
 293     TEMP_SET_PT_BOTH (opoint, opoint_byte);
 294
 295   if (first >= 0)
 296     {
 297       signal_after_change (first, last + 1 - first, last + 1 - first);
 298       update_compositions (first, last + 1, CHECK_ALL);
 299     }
 300 }
 301
 302 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
 303        doc: /* Convert the region to upper case.  In programs, wants two arguments.
 304 These arguments specify the starting and ending character numbers of
 305 the region to operate on.  When used as a command, the text between
 306 point and the mark is operated on.
 307 See also `capitalize-region'.  */)
 308      (beg, end)
 309      Lisp_Object beg, end;
 310 {
 311   casify_region (CASE_UP, beg, end);
 312   return Qnil;
 313 }
 314
 315 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
 316        doc: /* Convert the region to lower case.  In programs, wants two arguments.
 317 These arguments specify the starting and ending character numbers of
 318 the region to operate on.  When used as a command, the text between
 319 point and the mark is operated on.  */)
 320      (beg, end)
 321      Lisp_Object beg, end;
 322 {
 323   casify_region (CASE_DOWN, beg, end);
 324   return Qnil;
 325 }
 326
 327 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
 328        doc: /* Convert the region to capitalized form.
 329 Capitalized form means each word's first character is upper case
 330 and the rest of it is lower case.
 331 In programs, give two arguments, the starting and ending
 332 character positions to operate on.  */)
 333      (beg, end)
 334      Lisp_Object beg, end;
 335 {
 336   casify_region (CASE_CAPITALIZE, beg, end);
 337   return Qnil;
 338 }
 339
 340 /* Like Fcapitalize_region but change only the initials.  */
 341
 342 DEFUN ("upcase-initials-region", Fupcase_initials_region,
 343        Supcase_initials_region, 2, 2, "r",
 344        doc: /* Upcase the initial of each word in the region.
 345 Subsequent letters of each word are not changed.
 346 In programs, give two arguments, the starting and ending
 347 character positions to operate on.  */)
 348      (beg, end)
 349      Lisp_Object beg, end;
 350 {
 351   casify_region (CASE_CAPITALIZE_UP, beg, end);
 352   return Qnil;
 353 }
 354 \f
 355 static Lisp_Object
 356 operate_on_word (arg, newpoint)
 357      Lisp_Object arg;
 358      EMACS_INT *newpoint;
 359 {
 360   Lisp_Object val;
 361   int farend;
 362   int iarg;
 363
 364   CHECK_NUMBER (arg);
 365   iarg = XINT (arg);
 366   farend = scan_words (PT, iarg);
 367   if (!farend)
 368     farend = iarg > 0 ? ZV : BEGV;
 369
 370   *newpoint = PT > farend ? PT : farend;
 371   XSETFASTINT (val, farend);
 372
 373   return val;
 374 }
 375
 376 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
 377        doc: /* Convert following word (or ARG words) to upper case, moving over.
 378 With negative argument, convert previous words but do not move.
 379 See also `capitalize-word'.  */)
 380      (arg)
 381      Lisp_Object arg;
 382 {
 383   Lisp_Object beg, end;
 384   EMACS_INT newpoint;
 385   XSETFASTINT (beg, PT);
 386   end = operate_on_word (arg, &newpoint);
 387   casify_region (CASE_UP, beg, end);
 388   SET_PT (newpoint);
 389   return Qnil;
 390 }
 391
 392 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 393        doc: /* Convert following word (or ARG words) to lower case, moving over.
 394 With negative argument, convert previous words but do not move.  */)
 395      (arg)
 396      Lisp_Object arg;
 397 {
 398   Lisp_Object beg, end;
 399   EMACS_INT newpoint;
 400   XSETFASTINT (beg, PT);
 401   end = operate_on_word (arg, &newpoint);
 402   casify_region (CASE_DOWN, beg, end);
 403   SET_PT (newpoint);
 404   return Qnil;
 405 }
 406
 407 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 408        doc: /* Capitalize the following word (or ARG words), moving over.
 409 This gives the word(s) a first character in upper case
 410 and the rest lower case.
 411 With negative argument, capitalize previous words but do not move.  */)
 412      (arg)
 413      Lisp_Object arg;
 414 {
 415   Lisp_Object beg, end;
 416   EMACS_INT newpoint;
 417   XSETFASTINT (beg, PT);
 418   end = operate_on_word (arg, &newpoint);
 419   casify_region (CASE_CAPITALIZE, beg, end);
 420   SET_PT (newpoint);
 421   return Qnil;
 422 }
 423 \f
 424 void
 425 syms_of_casefiddle ()
 426 {
 427   Qidentity = intern ("identity");
 428   staticpro (&Qidentity);
 429   defsubr (&Supcase);
 430   defsubr (&Sdowncase);
 431   defsubr (&Scapitalize);
 432   defsubr (&Supcase_initials);
 433   defsubr (&Supcase_region);
 434   defsubr (&Sdowncase_region);
 435   defsubr (&Scapitalize_region);
 436   defsubr (&Supcase_initials_region);
 437   defsubr (&Supcase_word);
 438   defsubr (&Sdowncase_word);
 439   defsubr (&Scapitalize_word);
 440 }
 441
 442 void
 443 keys_of_casefiddle ()
 444 {
 445   initial_define_key (control_x_map, Ctl('U'), "upcase-region");
 446   Fput (intern ("upcase-region"), Qdisabled, Qt);
 447   initial_define_key (control_x_map, Ctl('L'), "downcase-region");
 448   Fput (intern ("downcase-region"), Qdisabled, Qt);
 449
 450   initial_define_key (meta_map, 'u', "upcase-word");
 451   initial_define_key (meta_map, 'l', "downcase-word");
 452   initial_define_key (meta_map, 'c', "capitalize-word");
 453 }
 454
 455 /* arch-tag: 60a73c66-5489-47e7-a81f-cead4057c526
 456    (do not change this comment) */