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

   1 /* GNU Emacs case conversion functions.
   2
   3 Copyright (C) 1985, 1994, 1997-1999, 2001-2016 Free Software Foundation,
   4 Inc.
   5
   6 This file is part of GNU Emacs.
   7
   8 GNU Emacs is free software: you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation, either version 3 of the License, or (at
  11 your option) any later version.
  12
  13 GNU Emacs is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  20
  21
  22 #include <config.h>
  23
  24 #include "lisp.h"
  25 #include "character.h"
  26 #include "buffer.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 \f
  34 static Lisp_Object
  35 casify_object (enum case_action flag, Lisp_Object obj)
  36 {
  37   int c, c1;
  38   bool inword = flag == CASE_DOWN;
  39
  40   /* If the case table is flagged as modified, rescan it.  */
  41   if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
  42     Fset_case_table (BVAR (current_buffer, downcase_table));
  43
  44   if (INTEGERP (obj))
  45     {
  46       int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
  47                       | CHAR_SHIFT | CHAR_CTL | CHAR_META);
  48       int flags = XINT (obj) & flagbits;
  49       bool multibyte = ! NILP (BVAR (current_buffer,
  50                                      enable_multibyte_characters));
  51
  52       /* If the character has higher bits set
  53          above the flags, return it unchanged.
  54          It is not a real character.  */
  55       if (UNSIGNED_CMP (XFASTINT (obj), >, flagbits))
  56         return obj;
  57
  58       c1 = XFASTINT (obj) & ~flagbits;
  59       /* FIXME: Even if enable-multibyte-characters is nil, we may
  60          manipulate multibyte chars.  This means we have a bug for latin-1
  61          chars since when we receive an int 128-255 we can't tell whether
  62          it's an eight-bit byte or a latin-1 char.  */
  63       if (c1 >= 256)
  64         multibyte = 1;
  65       if (! multibyte)
  66         MAKE_CHAR_MULTIBYTE (c1);
  67       c = downcase (c1);
  68       if (inword)
  69         XSETFASTINT (obj, c | flags);
  70       else if (c == (XFASTINT (obj) & ~flagbits))
  71         {
  72           if (! inword)
  73             c = upcase1 (c1);
  74           if (! multibyte)
  75             MAKE_CHAR_UNIBYTE (c);
  76           XSETFASTINT (obj, c | flags);
  77         }
  78       return obj;
  79     }
  80
  81   if (!STRINGP (obj))
  82     wrong_type_argument (Qchar_or_string_p, obj);
  83   else if (!STRING_MULTIBYTE (obj))
  84     {
  85       ptrdiff_t i;
  86       ptrdiff_t size = SCHARS (obj);
  87
  88       obj = Fcopy_sequence (obj);
  89       for (i = 0; i < size; i++)
  90         {
  91           c = SREF (obj, i);
  92           MAKE_CHAR_MULTIBYTE (c);
  93           c1 = c;
  94           if (inword && flag != CASE_CAPITALIZE_UP)
  95             c = downcase (c);
  96           else if (!uppercasep (c)
  97                    && (!inword || flag != CASE_CAPITALIZE_UP))
  98             c = upcase1 (c1);
  99           if ((int) flag >= (int) CASE_CAPITALIZE)
 100             inword = (SYNTAX (c) == Sword);
 101           if (c != c1)
 102             {
 103               MAKE_CHAR_UNIBYTE (c);
 104               /* If the char can't be converted to a valid byte, just don't
 105                  change it.  */
 106               if (c >= 0 && c < 256)
 107                 SSET (obj, i, c);
 108             }
 109         }
 110       return obj;
 111     }
 112   else
 113     {
 114       ptrdiff_t i, i_byte, size = SCHARS (obj);
 115       int len;
 116       USE_SAFE_ALLOCA;
 117       ptrdiff_t o_size;
 118       if (INT_MULTIPLY_WRAPV (size, MAX_MULTIBYTE_LENGTH, &o_size))
 119         o_size = PTRDIFF_MAX;
 120       unsigned char *dst = SAFE_ALLOCA (o_size);
 121       unsigned char *o = dst;
 122
 123       for (i = i_byte = 0; i < size; i++, i_byte += len)
 124         {
 125           if (o_size - MAX_MULTIBYTE_LENGTH < o - dst)
 126             string_overflow ();
 127           c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, len);
 128           if (inword && flag != CASE_CAPITALIZE_UP)
 129             c = downcase (c);
 130           else if (!uppercasep (c)
 131                    && (!inword || flag != CASE_CAPITALIZE_UP))
 132             c = upcase1 (c);
 133           if ((int) flag >= (int) CASE_CAPITALIZE)
 134             inword = (SYNTAX (c) == Sword);
 135           o += CHAR_STRING (c, o);
 136         }
 137       eassert (o - dst <= o_size);
 138       obj = make_multibyte_string ((char *) dst, size, o - dst);
 139       SAFE_FREE ();
 140       return obj;
 141     }
 142 }
 143
 144 DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
 145        doc: /* Convert argument to upper case and return that.
 146 The argument may be a character or string.  The result has the same type.
 147 The argument object is not altered--the value is a copy.
 148 See also `capitalize', `downcase' and `upcase-initials'.  */)
 149   (Lisp_Object obj)
 150 {
 151   return casify_object (CASE_UP, obj);
 152 }
 153
 154 DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
 155        doc: /* Convert argument to lower case and return that.
 156 The argument may be a character or string.  The result has the same type.
 157 The argument object is not altered--the value is a copy.  */)
 158   (Lisp_Object obj)
 159 {
 160   return casify_object (CASE_DOWN, obj);
 161 }
 162
 163 DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
 164        doc: /* Convert argument to capitalized form and return that.
 165 This means that each word's first character is upper case
 166 and the rest is lower case.
 167 The argument may be a character or string.  The result has the same type.
 168 The argument object is not altered--the value is a copy.  */)
 169   (Lisp_Object obj)
 170 {
 171   return casify_object (CASE_CAPITALIZE, obj);
 172 }
 173
 174 /* Like Fcapitalize but change only the initials.  */
 175
 176 DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0,
 177        doc: /* Convert the initial of each word in the argument to upper case.
 178 Do not change the other letters of each word.
 179 The argument may be a character or string.  The result has the same type.
 180 The argument object is not altered--the value is a copy.  */)
 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 static void
 190 casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e)
 191 {
 192   int c;
 193   bool inword = flag == CASE_DOWN;
 194   bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
 195   ptrdiff_t start, end;
 196   ptrdiff_t start_byte;
 197
 198   /* Position of first and last changes.  */
 199   ptrdiff_t first = -1, last IF_LINT (= 0);
 200
 201   ptrdiff_t opoint = PT;
 202   ptrdiff_t opoint_byte = PT_BYTE;
 203
 204   if (EQ (b, e))
 205     /* Not modifying because nothing marked */
 206     return;
 207
 208   /* If the case table is flagged as modified, rescan it.  */
 209   if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
 210     Fset_case_table (BVAR (current_buffer, downcase_table));
 211
 212   validate_region (&b, &e);
 213   start = XFASTINT (b);
 214   end = XFASTINT (e);
 215   modify_text (start, end);
 216   record_change (start, end - start);
 217   start_byte = CHAR_TO_BYTE (start);
 218
 219   SETUP_BUFFER_SYNTAX_TABLE (); /* For syntax_prefix_flag_p.  */
 220
 221   while (start < end)
 222     {
 223       int c2, len;
 224
 225       if (multibyte)
 226         {
 227           c = FETCH_MULTIBYTE_CHAR (start_byte);
 228           len = CHAR_BYTES (c);
 229         }
 230       else
 231         {
 232           c = FETCH_BYTE (start_byte);
 233           MAKE_CHAR_MULTIBYTE (c);
 234           len = 1;
 235         }
 236       c2 = c;
 237       if (inword && flag != CASE_CAPITALIZE_UP)
 238         c = downcase (c);
 239       else if (!uppercasep (c)
 240                && (!inword || flag != CASE_CAPITALIZE_UP))
 241         c = upcase1 (c);
 242       if ((int) flag >= (int) CASE_CAPITALIZE)
 243         inword = ((SYNTAX (c) == Sword)
 244                   && (inword || !syntax_prefix_flag_p (c)));
 245       if (c != c2)
 246         {
 247           last = start;
 248           if (first < 0)
 249             first = start;
 250
 251           if (! multibyte)
 252             {
 253               MAKE_CHAR_UNIBYTE (c);
 254               FETCH_BYTE (start_byte) = c;
 255             }
 256           else if (ASCII_CHAR_P (c2) && ASCII_CHAR_P (c))
 257             FETCH_BYTE (start_byte) = c;
 258           else
 259             {
 260               int tolen = CHAR_BYTES (c);
 261               int j;
 262               unsigned char str[MAX_MULTIBYTE_LENGTH];
 263
 264               CHAR_STRING (c, str);
 265               if (len == tolen)
 266                 {
 267                   /* Length is unchanged.  */
 268                   for (j = 0; j < len; ++j)
 269                     FETCH_BYTE (start_byte + j) = str[j];
 270                 }
 271               else
 272                 {
 273                   /* Replace one character with the other,
 274                      keeping text properties the same.  */
 275                   replace_range_2 (start, start_byte,
 276                                    start + 1, start_byte + len,
 277                                    (char *) str, 1, tolen,
 278                                    0);
 279                   len = tolen;
 280                 }
 281             }
 282         }
 283       start++;
 284       start_byte += len;
 285     }
 286
 287   if (PT != opoint)
 288     TEMP_SET_PT_BOTH (opoint, opoint_byte);
 289
 290   if (first >= 0)
 291     {
 292       signal_after_change (first, last + 1 - first, last + 1 - first);
 293       update_compositions (first, last + 1, CHECK_ALL);
 294     }
 295 }
 296
 297 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
 298        doc: /* Convert the region to upper case.  In programs, wants two arguments.
 299 These arguments specify the starting and ending character numbers of
 300 the region to operate on.  When used as a command, the text between
 301 point and the mark is operated on.
 302 See also `capitalize-region'.  */)
 303   (Lisp_Object beg, Lisp_Object end)
 304 {
 305   casify_region (CASE_UP, beg, end);
 306   return Qnil;
 307 }
 308
 309 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 3,
 310        "(list (region-beginning) (region-end) (region-noncontiguous-p))",
 311        doc: /* Convert the region to lower case.  In programs, wants two arguments.
 312 These arguments specify the starting and ending character numbers of
 313 the region to operate on.  When used as a command, the text between
 314 point and the mark is operated on.  */)
 315   (Lisp_Object beg, Lisp_Object end, Lisp_Object region_noncontiguous_p)
 316 {
 317   Lisp_Object bounds = Qnil;
 318
 319   if (!NILP (region_noncontiguous_p))
 320     {
 321       bounds = call1 (Fsymbol_value (intern ("region-extract-function")),
 322                       intern ("bounds"));
 323
 324       while (CONSP (bounds))
 325         {
 326           casify_region (CASE_DOWN, XCAR (XCAR (bounds)), XCDR (XCAR (bounds)));
 327           bounds = XCDR (bounds);
 328         }
 329     }
 330   else
 331     casify_region (CASE_DOWN, beg, end);
 332
 333   return Qnil;
 334 }
 335
 336 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
 337        doc: /* Convert the region to capitalized form.
 338 Capitalized form means each word's first character is upper case
 339 and the rest of it is lower case.
 340 In programs, give two arguments, the starting and ending
 341 character positions to operate on.  */)
 342   (Lisp_Object beg, Lisp_Object end)
 343 {
 344   casify_region (CASE_CAPITALIZE, beg, end);
 345   return Qnil;
 346 }
 347
 348 /* Like Fcapitalize_region but change only the initials.  */
 349
 350 DEFUN ("upcase-initials-region", Fupcase_initials_region,
 351        Supcase_initials_region, 2, 2, "r",
 352        doc: /* Upcase the initial of each word in the region.
 353 Subsequent letters of each word are not changed.
 354 In programs, give two arguments, the starting and ending
 355 character positions to operate on.  */)
 356   (Lisp_Object beg, Lisp_Object end)
 357 {
 358   casify_region (CASE_CAPITALIZE_UP, beg, end);
 359   return Qnil;
 360 }
 361 \f
 362 static Lisp_Object
 363 operate_on_word (Lisp_Object arg, ptrdiff_t *newpoint)
 364 {
 365   Lisp_Object val;
 366   ptrdiff_t farend;
 367   EMACS_INT iarg;
 368
 369   CHECK_NUMBER (arg);
 370   iarg = XINT (arg);
 371   farend = scan_words (PT, iarg);
 372   if (!farend)
 373     farend = iarg > 0 ? ZV : BEGV;
 374
 375   *newpoint = PT > farend ? PT : farend;
 376   XSETFASTINT (val, farend);
 377
 378   return val;
 379 }
 380
 381 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
 382        doc: /* Convert to upper case from point to end of word, moving over.
 383
 384 If point is in the middle of a word, the part of that word before point
 385 is ignored when moving forward.
 386
 387 With negative argument, convert previous words but do not move.
 388 See also `capitalize-word'.  */)
 389   (Lisp_Object arg)
 390 {
 391   Lisp_Object beg, end;
 392   ptrdiff_t newpoint;
 393   XSETFASTINT (beg, PT);
 394   end = operate_on_word (arg, &newpoint);
 395   casify_region (CASE_UP, beg, end);
 396   SET_PT (newpoint);
 397   return Qnil;
 398 }
 399
 400 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
 401        doc: /* Convert to lower case from point to end of word, moving over.
 402
 403 If point is in the middle of a word, the part of that word before point
 404 is ignored when moving forward.
 405
 406 With negative argument, convert previous words but do not move.  */)
 407   (Lisp_Object arg)
 408 {
 409   Lisp_Object beg, end;
 410   ptrdiff_t newpoint;
 411   XSETFASTINT (beg, PT);
 412   end = operate_on_word (arg, &newpoint);
 413   casify_region (CASE_DOWN, beg, end);
 414   SET_PT (newpoint);
 415   return Qnil;
 416 }
 417
 418 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
 419        doc: /* Capitalize from point to the end of word, moving over.
 420 With numerical argument ARG, capitalize the next ARG-1 words as well.
 421 This gives the word(s) a first character in upper case
 422 and the rest lower case.
 423
 424 If point is in the middle of a word, the part of that word before point
 425 is ignored when moving forward.
 426
 427 With negative argument, capitalize previous words but do not move.  */)
 428   (Lisp_Object arg)
 429 {
 430   Lisp_Object beg, end;
 431   ptrdiff_t newpoint;
 432   XSETFASTINT (beg, PT);
 433   end = operate_on_word (arg, &newpoint);
 434   casify_region (CASE_CAPITALIZE, beg, end);
 435   SET_PT (newpoint);
 436   return Qnil;
 437 }
 438 \f
 439 void
 440 syms_of_casefiddle (void)
 441 {
 442   DEFSYM (Qidentity, "identity");
 443   defsubr (&Supcase);
 444   defsubr (&Sdowncase);
 445   defsubr (&Scapitalize);
 446   defsubr (&Supcase_initials);
 447   defsubr (&Supcase_region);
 448   defsubr (&Sdowncase_region);
 449   defsubr (&Scapitalize_region);
 450   defsubr (&Supcase_initials_region);
 451   defsubr (&Supcase_word);
 452   defsubr (&Sdowncase_word);
 453   defsubr (&Scapitalize_word);
 454 }
 455
 456 void
 457 keys_of_casefiddle (void)
 458 {
 459   initial_define_key (control_x_map, Ctl ('U'), "upcase-region");
 460   Fput (intern ("upcase-region"), Qdisabled, Qt);
 461   initial_define_key (control_x_map, Ctl ('L'), "downcase-region");
 462   Fput (intern ("downcase-region"), Qdisabled, Qt);
 463
 464   initial_define_key (meta_map, 'u', "upcase-word");
 465   initial_define_key (meta_map, 'l', "downcase-word");
 466   initial_define_key (meta_map, 'c', "capitalize-word");
 467 }