src/doc.c

   1 /* Record indices of function doc strings stored in a file.
   2
   3 Copyright (C) 1985-1986, 1993-1995, 1997-2012 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 of the License, or
  10 (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20
  21 #include <config.h>
  22
  23 #include <sys/types.h>
  24 #include <sys/file.h>   /* Must be after sys/types.h for USG*/
  25 #include <fcntl.h>
  26 #include <unistd.h>
  27
  28 #include <c-ctype.h>
  29
  30 #include "lisp.h"
  31 #include "character.h"
  32 #include "buffer.h"
  33 #include "keyboard.h"
  34 #include "keymap.h"
  35 #include "buildobj.h"
  36
  37 Lisp_Object Qfunction_documentation;
  38
  39 /* Buffer used for reading from documentation file.  */
  40 static char *get_doc_string_buffer;
  41 static ptrdiff_t get_doc_string_buffer_size;
  42
  43 static unsigned char *read_bytecode_pointer;
  44
  45 /* readchar in lread.c calls back here to fetch the next byte.
  46    If UNREADFLAG is 1, we unread a byte.  */
  47
  48 int
  49 read_bytecode_char (bool unreadflag)
  50 {
  51   if (unreadflag)
  52     {
  53       read_bytecode_pointer--;
  54       return 0;
  55     }
  56   return *read_bytecode_pointer++;
  57 }
  58
  59 /* Extract a doc string from a file.  FILEPOS says where to get it.
  60    If it is an integer, use that position in the standard DOC-... file.
  61    If it is (FILE . INTEGER), use FILE as the file name
  62    and INTEGER as the position in that file.
  63    But if INTEGER is negative, make it positive.
  64    (A negative integer is used for user variables, so we can distinguish
  65    them without actually fetching the doc string.)
  66
  67    If the location does not point to the beginning of a docstring
  68    (e.g. because the file has been modified and the location is stale),
  69    return nil.
  70
  71    If UNIBYTE, always make a unibyte string.
  72
  73    If DEFINITION, assume this is for reading
  74    a dynamic function definition; convert the bytestring
  75    and the constants vector with appropriate byte handling,
  76    and return a cons cell.  */
  77
  78 Lisp_Object
  79 get_doc_string (Lisp_Object filepos, bool unibyte, bool definition)
  80 {
  81   char *from, *to, *name, *p, *p1;
  82   int fd;
  83   ptrdiff_t minsize;
  84   int offset;
  85   EMACS_INT position;
  86   Lisp_Object file, tem;
  87   USE_SAFE_ALLOCA;
  88
  89   if (INTEGERP (filepos))
  90     {
  91       file = Vdoc_file_name;
  92       position = XINT (filepos);
  93     }
  94   else if (CONSP (filepos))
  95     {
  96       file = XCAR (filepos);
  97       position = XINT (XCDR (filepos));
  98     }
  99   else
 100     return Qnil;
 101
 102   if (position < 0)
 103     position = - position;
 104
 105   if (!STRINGP (Vdoc_directory))
 106     return Qnil;
 107
 108   if (!STRINGP (file))
 109     return Qnil;
 110
 111   /* Put the file name in NAME as a C string.
 112      If it is relative, combine it with Vdoc_directory.  */
 113
 114   tem = Ffile_name_absolute_p (file);
 115   file = ENCODE_FILE (file);
 116   if (NILP (tem))
 117     {
 118       Lisp_Object docdir = ENCODE_FILE (Vdoc_directory);
 119       minsize = SCHARS (docdir);
 120       /* sizeof ("../etc/") == 8 */
 121       if (minsize < 8)
 122         minsize = 8;
 123       name = SAFE_ALLOCA (minsize + SCHARS (file) + 8);
 124       strcpy (name, SSDATA (docdir));
 125       strcat (name, SSDATA (file));
 126     }
 127   else
 128     {
 129       name = SSDATA (file);
 130     }
 131
 132   fd = emacs_open (name, O_RDONLY, 0);
 133   if (fd < 0)
 134     {
 135 #ifndef CANNOT_DUMP
 136       if (!NILP (Vpurify_flag))
 137         {
 138           /* Preparing to dump; DOC file is probably not installed.
 139              So check in ../etc.  */
 140           strcpy (name, "../etc/");
 141           strcat (name, SSDATA (file));
 142
 143           fd = emacs_open (name, O_RDONLY, 0);
 144         }
 145 #endif
 146       if (fd < 0)
 147         error ("Cannot open doc string file \"%s\"", name);
 148     }
 149
 150   /* Seek only to beginning of disk block.  */
 151   /* Make sure we read at least 1024 bytes before `position'
 152      so we can check the leading text for consistency.  */
 153   offset = min (position, max (1024, position % (8 * 1024)));
 154   if (TYPE_MAXIMUM (off_t) < position
 155       || lseek (fd, position - offset, 0) < 0)
 156     {
 157       emacs_close (fd);
 158       error ("Position %"pI"d out of range in doc string file \"%s\"",
 159              position, name);
 160     }
 161
 162   SAFE_FREE ();
 163
 164   /* Read the doc string into get_doc_string_buffer.
 165      P points beyond the data just read.  */
 166
 167   p = get_doc_string_buffer;
 168   while (1)
 169     {
 170       ptrdiff_t space_left = (get_doc_string_buffer_size - 1
 171                               - (p - get_doc_string_buffer));
 172       int nread;
 173
 174       /* Allocate or grow the buffer if we need to.  */
 175       if (space_left <= 0)
 176         {
 177           ptrdiff_t in_buffer = p - get_doc_string_buffer;
 178           get_doc_string_buffer =
 179             xpalloc (get_doc_string_buffer, &get_doc_string_buffer_size,
 180                      16 * 1024, -1, 1);
 181           p = get_doc_string_buffer + in_buffer;
 182           space_left = (get_doc_string_buffer_size - 1
 183                         - (p - get_doc_string_buffer));
 184         }
 185
 186       /* Read a disk block at a time.
 187          If we read the same block last time, maybe skip this?  */
 188       if (space_left > 1024 * 8)
 189         space_left = 1024 * 8;
 190       nread = emacs_read (fd, p, space_left);
 191       if (nread < 0)
 192         {
 193           emacs_close (fd);
 194           error ("Read error on documentation file");
 195         }
 196       p[nread] = 0;
 197       if (!nread)
 198         break;
 199       if (p == get_doc_string_buffer)
 200         p1 = strchr (p + offset, '\037');
 201       else
 202         p1 = strchr (p, '\037');
 203       if (p1)
 204         {
 205           *p1 = 0;
 206           p = p1;
 207           break;
 208         }
 209       p += nread;
 210     }
 211   emacs_close (fd);
 212
 213   /* Sanity checking.  */
 214   if (CONSP (filepos))
 215     {
 216       int test = 1;
 217       if (get_doc_string_buffer[offset - test++] != ' ')
 218         return Qnil;
 219       while (get_doc_string_buffer[offset - test] >= '0'
 220              && get_doc_string_buffer[offset - test] <= '9')
 221         test++;
 222       if (get_doc_string_buffer[offset - test++] != '@'
 223           || get_doc_string_buffer[offset - test] != '#')
 224         return Qnil;
 225     }
 226   else
 227     {
 228       int test = 1;
 229       if (get_doc_string_buffer[offset - test++] != '\n')
 230         return Qnil;
 231       while (get_doc_string_buffer[offset - test] > ' ')
 232         test++;
 233       if (get_doc_string_buffer[offset - test] != '\037')
 234         return Qnil;
 235     }
 236
 237   /* Scan the text and perform quoting with ^A (char code 1).
 238      ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_.  */
 239   from = get_doc_string_buffer + offset;
 240   to = get_doc_string_buffer + offset;
 241   while (from != p)
 242     {
 243       if (*from == 1)
 244         {
 245           int c;
 246
 247           from++;
 248           c = *from++;
 249           if (c == 1)
 250             *to++ = c;
 251           else if (c == '0')
 252             *to++ = 0;
 253           else if (c == '_')
 254             *to++ = 037;
 255           else
 256             {
 257               unsigned char uc = c;
 258               error ("\
 259 Invalid data in documentation file -- %c followed by code %03o",
 260                      1, uc);
 261             }
 262         }
 263       else
 264         *to++ = *from++;
 265     }
 266
 267   /* If DEFINITION, read from this buffer
 268      the same way we would read bytes from a file.  */
 269   if (definition)
 270     {
 271       read_bytecode_pointer = (unsigned char *) get_doc_string_buffer + offset;
 272       return Fread (Qlambda);
 273     }
 274
 275   if (unibyte)
 276     return make_unibyte_string (get_doc_string_buffer + offset,
 277                                 to - (get_doc_string_buffer + offset));
 278   else
 279     {
 280       /* The data determines whether the string is multibyte.  */
 281       ptrdiff_t nchars =
 282         multibyte_chars_in_text (((unsigned char *) get_doc_string_buffer
 283                                   + offset),
 284                                  to - (get_doc_string_buffer + offset));
 285       return make_string_from_bytes (get_doc_string_buffer + offset,
 286                                      nchars,
 287                                      to - (get_doc_string_buffer + offset));
 288     }
 289 }
 290
 291 /* Get a string from position FILEPOS and pass it through the Lisp reader.
 292    We use this for fetching the bytecode string and constants vector
 293    of a compiled function from the .elc file.  */
 294
 295 Lisp_Object
 296 read_doc_string (Lisp_Object filepos)
 297 {
 298   return get_doc_string (filepos, 0, 1);
 299 }
 300
 301 static bool
 302 reread_doc_file (Lisp_Object file)
 303 {
 304 #if 0
 305   Lisp_Object reply, prompt[3];
 306   struct gcpro gcpro1;
 307   GCPRO1 (file);
 308   prompt[0] = build_string ("File ");
 309   prompt[1] = NILP (file) ? Vdoc_file_name : file;
 310   prompt[2] = build_string (" is out of sync.  Reload? ");
 311   reply = Fy_or_n_p (Fconcat (3, prompt));
 312   UNGCPRO;
 313   if (NILP (reply))
 314     return 0;
 315 #endif
 316
 317   if (NILP (file))
 318     Fsnarf_documentation (Vdoc_file_name);
 319   else
 320     Fload (file, Qt, Qt, Qt, Qnil);
 321
 322   return 1;
 323 }
 324
 325 DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
 326        doc: /* Return the documentation string of FUNCTION.
 327 Unless a non-nil second argument RAW is given, the
 328 string is passed through `substitute-command-keys'.  */)
 329   (Lisp_Object function, Lisp_Object raw)
 330 {
 331   Lisp_Object fun;
 332   Lisp_Object funcar;
 333   Lisp_Object doc;
 334   bool try_reload = 1;
 335
 336  documentation:
 337
 338   doc = Qnil;
 339
 340   if (SYMBOLP (function))
 341     {
 342       Lisp_Object tem = Fget (function, Qfunction_documentation);
 343       if (!NILP (tem))
 344         return Fdocumentation_property (function, Qfunction_documentation,
 345                                         raw);
 346     }
 347
 348   fun = Findirect_function (function, Qnil);
 349   if (SUBRP (fun))
 350     {
 351       if (XSUBR (fun)->doc == 0)
 352         return Qnil;
 353       /* FIXME: This is not portable, as it assumes that string
 354          pointers have the top bit clear.  */
 355       else if ((intptr_t) XSUBR (fun)->doc >= 0)
 356         doc = build_string (XSUBR (fun)->doc);
 357       else
 358         doc = make_number ((intptr_t) XSUBR (fun)->doc);
 359     }
 360   else if (COMPILEDP (fun))
 361     {
 362       if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) <= COMPILED_DOC_STRING)
 363         return Qnil;
 364       else
 365         {
 366           Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING);
 367           if (STRINGP (tem))
 368             doc = tem;
 369           else if (NATNUMP (tem) || CONSP (tem))
 370             doc = tem;
 371           else
 372             return Qnil;
 373         }
 374     }
 375   else if (STRINGP (fun) || VECTORP (fun))
 376     {
 377       return build_string ("Keyboard macro.");
 378     }
 379   else if (CONSP (fun))
 380     {
 381       funcar = XCAR (fun);
 382       if (!SYMBOLP (funcar))
 383         xsignal1 (Qinvalid_function, fun);
 384       else if (EQ (funcar, Qkeymap))
 385         return build_string ("Prefix command (definition is a keymap associating keystrokes with commands).");
 386       else if (EQ (funcar, Qlambda)
 387                || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1))
 388                || EQ (funcar, Qautoload))
 389         {
 390           Lisp_Object tem1 = Fcdr (Fcdr (fun));
 391           Lisp_Object tem = Fcar (tem1);
 392           if (STRINGP (tem))
 393             doc = tem;
 394           /* Handle a doc reference--but these never come last
 395              in the function body, so reject them if they are last.  */
 396           else if ((NATNUMP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
 397                    && !NILP (XCDR (tem1)))
 398             doc = tem;
 399           else
 400             return Qnil;
 401         }
 402       else if (EQ (funcar, Qmacro))
 403         return Fdocumentation (Fcdr (fun), raw);
 404       else
 405         goto oops;
 406     }
 407   else
 408     {
 409     oops:
 410       xsignal1 (Qinvalid_function, fun);
 411     }
 412
 413   /* Check for an advised function.  Its doc string
 414      has an `ad-advice-info' text property.  */
 415   if (STRINGP (doc))
 416     {
 417       Lisp_Object innerfunc;
 418       innerfunc = Fget_text_property (make_number (0),
 419                                       intern ("ad-advice-info"),
 420                                       doc);
 421       if (! NILP (innerfunc))
 422         doc = call1 (intern ("ad-make-advised-docstring"), innerfunc);
 423     }
 424
 425   /* If DOC is 0, it's typically because of a dumped file missing
 426      from the DOC file (bug in src/Makefile.in).  */
 427   if (EQ (doc, make_number (0)))
 428     doc = Qnil;
 429   if (INTEGERP (doc) || CONSP (doc))
 430     {
 431       Lisp_Object tem;
 432       tem = get_doc_string (doc, 0, 0);
 433       if (NILP (tem) && try_reload)
 434         {
 435           /* The file is newer, we need to reset the pointers.  */
 436           struct gcpro gcpro1, gcpro2;
 437           GCPRO2 (function, raw);
 438           try_reload = reread_doc_file (Fcar_safe (doc));
 439           UNGCPRO;
 440           if (try_reload)
 441             {
 442               try_reload = 0;
 443               goto documentation;
 444             }
 445         }
 446       else
 447         doc = tem;
 448     }
 449
 450   if (NILP (raw))
 451     doc = Fsubstitute_command_keys (doc);
 452   return doc;
 453 }
 454
 455 DEFUN ("documentation-property", Fdocumentation_property,
 456        Sdocumentation_property, 2, 3, 0,
 457        doc: /* Return the documentation string that is SYMBOL's PROP property.
 458 Third argument RAW omitted or nil means pass the result through
 459 `substitute-command-keys' if it is a string.
 460
 461 This differs from `get' in that it can refer to strings stored in the
 462 `etc/DOC' file; and that it evaluates documentation properties that
 463 aren't strings.  */)
 464   (Lisp_Object symbol, Lisp_Object prop, Lisp_Object raw)
 465 {
 466   bool try_reload = 1;
 467   Lisp_Object tem;
 468
 469  documentation_property:
 470
 471   tem = Fget (symbol, prop);
 472   if (EQ (tem, make_number (0)))
 473     tem = Qnil;
 474   if (INTEGERP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
 475     {
 476       Lisp_Object doc = tem;
 477       tem = get_doc_string (tem, 0, 0);
 478       if (NILP (tem) && try_reload)
 479         {
 480           /* The file is newer, we need to reset the pointers.  */
 481           struct gcpro gcpro1, gcpro2, gcpro3;
 482           GCPRO3 (symbol, prop, raw);
 483           try_reload = reread_doc_file (Fcar_safe (doc));
 484           UNGCPRO;
 485           if (try_reload)
 486             {
 487               try_reload = 0;
 488               goto documentation_property;
 489             }
 490         }
 491     }
 492   else if (!STRINGP (tem))
 493     /* Feval protects its argument.  */
 494     tem = Feval (tem, Qnil);
 495
 496   if (NILP (raw) && STRINGP (tem))
 497     tem = Fsubstitute_command_keys (tem);
 498   return tem;
 499 }
 500 \f
 501 /* Scanning the DOC files and placing docstring offsets into functions.  */
 502
 503 static void
 504 store_function_docstring (Lisp_Object obj, ptrdiff_t offset)
 505 {
 506   /* Don't use indirect_function here, or defaliases will apply their
 507      docstrings to the base functions (Bug#2603).  */
 508   Lisp_Object fun = SYMBOLP (obj) ? XSYMBOL (obj)->function : obj;
 509
 510   /* The type determines where the docstring is stored.  */
 511
 512   /* Lisp_Subrs have a slot for it.  */
 513   if (SUBRP (fun))
 514     {
 515       intptr_t negative_offset = - offset;
 516       XSUBR (fun)->doc = (char *) negative_offset;
 517     }
 518
 519   /* If it's a lisp form, stick it in the form.  */
 520   else if (CONSP (fun))
 521     {
 522       Lisp_Object tem;
 523
 524       tem = XCAR (fun);
 525       if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
 526           || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
 527         {
 528           tem = Fcdr (Fcdr (fun));
 529           if (CONSP (tem) && INTEGERP (XCAR (tem)))
 530             XSETCAR (tem, make_number (offset));
 531         }
 532       else if (EQ (tem, Qmacro))
 533         store_function_docstring (XCDR (fun), offset);
 534     }
 535
 536   /* Bytecode objects sometimes have slots for it.  */
 537   else if (COMPILEDP (fun))
 538     {
 539       /* This bytecode object must have a slot for the
 540          docstring, since we've found a docstring for it.  */
 541       if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING)
 542         ASET (fun, COMPILED_DOC_STRING, make_number (offset));
 543     }
 544 }
 545
 546 static const char buildobj[] = BUILDOBJ;
 547
 548 DEFUN ("Snarf-documentation", Fsnarf_documentation, Ssnarf_documentation,
 549        1, 1, 0,
 550        doc: /* Used during Emacs initialization to scan the `etc/DOC...' file.
 551 This searches the `etc/DOC...' file for doc strings and
 552 records them in function and variable definitions.
 553 The function takes one argument, FILENAME, a string;
 554 it specifies the file name (without a directory) of the DOC file.
 555 That file is found in `../etc' now; later, when the dumped Emacs is run,
 556 the same file name is found in the `doc-directory'.  */)
 557   (Lisp_Object filename)
 558 {
 559   int fd;
 560   char buf[1024 + 1];
 561   int filled;
 562   EMACS_INT pos;
 563   Lisp_Object sym;
 564   char *p, *name;
 565   bool skip_file = 0;
 566
 567   CHECK_STRING (filename);
 568
 569   if
 570 #ifndef CANNOT_DUMP
 571     (!NILP (Vpurify_flag))
 572 #else /* CANNOT_DUMP */
 573       (0)
 574 #endif /* CANNOT_DUMP */
 575     {
 576       name = alloca (SCHARS (filename) + 14);
 577       strcpy (name, "../etc/");
 578     }
 579   else
 580     {
 581       CHECK_STRING (Vdoc_directory);
 582       name = alloca (SCHARS (filename) + SCHARS (Vdoc_directory) + 1);
 583       strcpy (name, SSDATA (Vdoc_directory));
 584     }
 585   strcat (name, SSDATA (filename));     /*** Add this line ***/
 586
 587   /* Vbuild_files is nil when temacs is run, and non-nil after that.  */
 588   if (NILP (Vbuild_files))
 589   {
 590     const char *beg, *end;
 591
 592     for (beg = buildobj; *beg; beg = end)
 593       {
 594         ptrdiff_t len;
 595
 596         while (*beg && c_isspace (*beg)) ++beg;
 597
 598         for (end = beg; *end && ! c_isspace (*end); ++end)
 599           if (*end == '/') beg = end+1;  /* skip directory part  */
 600
 601         len = end - beg;
 602         if (len > 4 && end[-4] == '.' && end[-3] == 'o')
 603           len -= 2;  /* Just take .o if it ends in .obj  */
 604
 605         if (len > 0)
 606           Vbuild_files = Fcons (make_string (beg, len), Vbuild_files);
 607       }
 608     Vbuild_files = Fpurecopy (Vbuild_files);
 609   }
 610
 611   fd = emacs_open (name, O_RDONLY, 0);
 612   if (fd < 0)
 613     report_file_error ("Opening doc string file",
 614                        Fcons (build_string (name), Qnil));
 615   Vdoc_file_name = filename;
 616   filled = 0;
 617   pos = 0;
 618   while (1)
 619     {
 620       register char *end;
 621       if (filled < 512)
 622         filled += emacs_read (fd, &buf[filled], sizeof buf - 1 - filled);
 623       if (!filled)
 624         break;
 625
 626       buf[filled] = 0;
 627       p = buf;
 628       end = buf + (filled < 512 ? filled : filled - 128);
 629       while (p != end && *p != '\037') p++;
 630       /* p points to ^_Ffunctionname\n or ^_Vvarname\n or ^_Sfilename\n.  */
 631       if (p != end)
 632         {
 633           end = strchr (p, '\n');
 634
 635           /* See if this is a file name, and if it is a file in build-files.  */
 636           if (p[1] == 'S')
 637             {
 638               skip_file = 0;
 639               if (end - p > 4 && end[-2] == '.'
 640                   && (end[-1] == 'o' || end[-1] == 'c'))
 641                 {
 642                   ptrdiff_t len = end - p - 2;
 643                   char *fromfile = alloca (len + 1);
 644                   memcpy (fromfile, &p[2], len);
 645                   fromfile[len] = 0;
 646                   if (fromfile[len-1] == 'c')
 647                     fromfile[len-1] = 'o';
 648
 649                   skip_file = NILP (Fmember (build_string (fromfile),
 650                                              Vbuild_files));
 651                 }
 652             }
 653
 654           sym = oblookup (Vobarray, p + 2,
 655                           multibyte_chars_in_text ((unsigned char *) p + 2,
 656                                                    end - p - 2),
 657                           end - p - 2);
 658           /* Check skip_file so that when a function is defined several
 659              times in different files (typically, once in xterm, once in
 660              w32term, ...), we only pay attention to the one that
 661              matters.  */
 662           if (! skip_file && SYMBOLP (sym))
 663             {
 664               /* Attach a docstring to a variable?  */
 665               if (p[1] == 'V')
 666                 {
 667                   /* Install file-position as variable-documentation property
 668                      and make it negative for a user-variable
 669                      (doc starts with a `*').  */
 670                   if (!NILP (Fboundp (sym)))
 671                     Fput (sym, Qvariable_documentation,
 672                           make_number ((pos + end + 1 - buf)
 673                                        * (end[1] == '*' ? -1 : 1)));
 674                 }
 675
 676               /* Attach a docstring to a function?  */
 677               else if (p[1] == 'F')
 678                 {
 679                   if (!NILP (Ffboundp (sym)))
 680                     store_function_docstring (sym, pos + end + 1 - buf);
 681                 }
 682               else if (p[1] == 'S')
 683                 ; /* Just a source file name boundary marker.  Ignore it.  */
 684
 685               else
 686                 error ("DOC file invalid at position %"pI"d", pos);
 687             }
 688         }
 689       pos += end - buf;
 690       filled -= end - buf;
 691       memmove (buf, end, filled);
 692     }
 693   emacs_close (fd);
 694   return Qnil;
 695 }
 696 \f
 697 DEFUN ("substitute-command-keys", Fsubstitute_command_keys,
 698        Ssubstitute_command_keys, 1, 1, 0,
 699        doc: /* Substitute key descriptions for command names in STRING.
 700 Each substring of the form \\=\\[COMMAND] is replaced by either a
 701 keystroke sequence that invokes COMMAND, or "M-x COMMAND" if COMMAND
 702 is not on any keys.
 703
 704 Each substring of the form \\=\\{MAPVAR} is replaced by a summary of
 705 the value of MAPVAR as a keymap.  This summary is similar to the one
 706 produced by `describe-bindings'.  The summary ends in two newlines
 707 \(used by the helper function `help-make-xrefs' to find the end of the
 708 summary).
 709
 710 Each substring of the form \\=\\<MAPVAR> specifies the use of MAPVAR
 711 as the keymap for future \\=\\[COMMAND] substrings.
 712 \\=\\= quotes the following character and is discarded;
 713 thus, \\=\\=\\=\\= puts \\=\\= into the output, and \\=\\=\\=\\[ puts \\=\\[ into the output.
 714
 715 Return the original STRING if no substitutions are made.
 716 Otherwise, return a new string, without any text properties.  */)
 717   (Lisp_Object string)
 718 {
 719   char *buf;
 720   bool changed = 0;
 721   unsigned char *strp;
 722   char *bufp;
 723   ptrdiff_t idx;
 724   ptrdiff_t bsize;
 725   Lisp_Object tem;
 726   Lisp_Object keymap;
 727   unsigned char *start;
 728   ptrdiff_t length, length_byte;
 729   Lisp_Object name;
 730   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 731   bool multibyte;
 732   ptrdiff_t nchars;
 733
 734   if (NILP (string))
 735     return Qnil;
 736
 737   CHECK_STRING (string);
 738   tem = Qnil;
 739   keymap = Qnil;
 740   name = Qnil;
 741   GCPRO4 (string, tem, keymap, name);
 742
 743   multibyte = STRING_MULTIBYTE (string);
 744   nchars = 0;
 745
 746   /* KEYMAP is either nil (which means search all the active keymaps)
 747      or a specified local map (which means search just that and the
 748      global map).  If non-nil, it might come from Voverriding_local_map,
 749      or from a \\<mapname> construct in STRING itself..  */
 750   keymap = KVAR (current_kboard, Voverriding_terminal_local_map);
 751   if (NILP (keymap))
 752     keymap = Voverriding_local_map;
 753
 754   bsize = SBYTES (string);
 755   bufp = buf = xmalloc (bsize);
 756
 757   strp = SDATA (string);
 758   while (strp < SDATA (string) + SBYTES (string))
 759     {
 760       if (strp[0] == '\\' && strp[1] == '=')
 761         {
 762           /* \= quotes the next character;
 763              thus, to put in \[ without its special meaning, use \=\[.  */
 764           changed = 1;
 765           strp += 2;
 766           if (multibyte)
 767             {
 768               int len;
 769
 770               STRING_CHAR_AND_LENGTH (strp, len);
 771               if (len == 1)
 772                 *bufp = *strp;
 773               else
 774                 memcpy (bufp, strp, len);
 775               strp += len;
 776               bufp += len;
 777               nchars++;
 778             }
 779           else
 780             *bufp++ = *strp++, nchars++;
 781         }
 782       else if (strp[0] == '\\' && strp[1] == '[')
 783         {
 784           ptrdiff_t start_idx;
 785           bool follow_remap = 1;
 786
 787           changed = 1;
 788           strp += 2;            /* skip \[ */
 789           start = strp;
 790           start_idx = start - SDATA (string);
 791
 792           while ((strp - SDATA (string)
 793                   < SBYTES (string))
 794                  && *strp != ']')
 795             strp++;
 796           length_byte = strp - start;
 797
 798           strp++;               /* skip ] */
 799
 800           /* Save STRP in IDX.  */
 801           idx = strp - SDATA (string);
 802           name = Fintern (make_string ((char *) start, length_byte), Qnil);
 803
 804         do_remap:
 805           tem = Fwhere_is_internal (name, keymap, Qt, Qnil, Qnil);
 806
 807           if (VECTORP (tem) && ASIZE (tem) > 1
 808               && EQ (AREF (tem, 0), Qremap) && SYMBOLP (AREF (tem, 1))
 809               && follow_remap)
 810             {
 811               name = AREF (tem, 1);
 812               follow_remap = 0;
 813               goto do_remap;
 814             }
 815
 816           /* Note the Fwhere_is_internal can GC, so we have to take
 817              relocation of string contents into account.  */
 818           strp = SDATA (string) + idx;
 819           start = SDATA (string) + start_idx;
 820
 821           if (NILP (tem))       /* but not on any keys */
 822             {
 823               ptrdiff_t offset = bufp - buf;
 824               if (STRING_BYTES_BOUND - 4 < bsize)
 825                 string_overflow ();
 826               buf = xrealloc (buf, bsize += 4);
 827               bufp = buf + offset;
 828               memcpy (bufp, "M-x ", 4);
 829               bufp += 4;
 830               nchars += 4;
 831               if (multibyte)
 832                 length = multibyte_chars_in_text (start, length_byte);
 833               else
 834                 length = length_byte;
 835               goto subst;
 836             }
 837           else
 838             {                   /* function is on a key */
 839               tem = Fkey_description (tem, Qnil);
 840               goto subst_string;
 841             }
 842         }
 843       /* \{foo} is replaced with a summary of the keymap (symbol-value foo).
 844          \<foo> just sets the keymap used for \[cmd].  */
 845       else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<'))
 846         {
 847           struct buffer *oldbuf;
 848           ptrdiff_t start_idx;
 849           /* This is for computing the SHADOWS arg for describe_map_tree.  */
 850           Lisp_Object active_maps = Fcurrent_active_maps (Qnil, Qnil);
 851           Lisp_Object earlier_maps;
 852
 853           changed = 1;
 854           strp += 2;            /* skip \{ or \< */
 855           start = strp;
 856           start_idx = start - SDATA (string);
 857
 858           while ((strp - SDATA (string) < SBYTES (string))
 859                  && *strp != '}' && *strp != '>')
 860             strp++;
 861
 862           length_byte = strp - start;
 863           strp++;                       /* skip } or > */
 864
 865           /* Save STRP in IDX.  */
 866           idx = strp - SDATA (string);
 867
 868           /* Get the value of the keymap in TEM, or nil if undefined.
 869              Do this while still in the user's current buffer
 870              in case it is a local variable.  */
 871           name = Fintern (make_string ((char *) start, length_byte), Qnil);
 872           tem = Fboundp (name);
 873           if (! NILP (tem))
 874             {
 875               tem = Fsymbol_value (name);
 876               if (! NILP (tem))
 877                 {
 878                   tem = get_keymap (tem, 0, 1);
 879                   /* Note that get_keymap can GC.  */
 880                   strp = SDATA (string) + idx;
 881                   start = SDATA (string) + start_idx;
 882                 }
 883             }
 884
 885           /* Now switch to a temp buffer.  */
 886           oldbuf = current_buffer;
 887           set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
 888
 889           if (NILP (tem))
 890             {
 891               name = Fsymbol_name (name);
 892               insert_string ("\nUses keymap `");
 893               insert_from_string (name, 0, 0,
 894                                   SCHARS (name),
 895                                   SBYTES (name), 1);
 896               insert_string ("', which is not currently defined.\n");
 897               if (start[-1] == '<') keymap = Qnil;
 898             }
 899           else if (start[-1] == '<')
 900             keymap = tem;
 901           else
 902             {
 903               /* Get the list of active keymaps that precede this one.
 904                  If this one's not active, get nil.  */
 905               earlier_maps = Fcdr (Fmemq (tem, Freverse (active_maps)));
 906               describe_map_tree (tem, 1, Fnreverse (earlier_maps),
 907                                  Qnil, (char *)0, 1, 0, 0, 1);
 908             }
 909           tem = Fbuffer_string ();
 910           Ferase_buffer ();
 911           set_buffer_internal (oldbuf);
 912
 913         subst_string:
 914           start = SDATA (tem);
 915           length = SCHARS (tem);
 916           length_byte = SBYTES (tem);
 917         subst:
 918           {
 919             ptrdiff_t offset = bufp - buf;
 920             if (STRING_BYTES_BOUND - length_byte < bsize)
 921               string_overflow ();
 922             buf = xrealloc (buf, bsize += length_byte);
 923             bufp = buf + offset;
 924             memcpy (bufp, start, length_byte);
 925             bufp += length_byte;
 926             nchars += length;
 927             /* Check STRING again in case gc relocated it.  */
 928             strp = SDATA (string) + idx;
 929           }
 930         }
 931       else if (! multibyte)             /* just copy other chars */
 932         *bufp++ = *strp++, nchars++;
 933       else
 934         {
 935           int len;
 936
 937           STRING_CHAR_AND_LENGTH (strp, len);
 938           if (len == 1)
 939             *bufp = *strp;
 940           else
 941             memcpy (bufp, strp, len);
 942           strp += len;
 943           bufp += len;
 944           nchars++;
 945         }
 946     }
 947
 948   if (changed)                  /* don't bother if nothing substituted */
 949     tem = make_string_from_bytes (buf, nchars, bufp - buf);
 950   else
 951     tem = string;
 952   xfree (buf);
 953   RETURN_UNGCPRO (tem);
 954 }
 955 \f
 956 void
 957 syms_of_doc (void)
 958 {
 959   DEFSYM (Qfunction_documentation, "function-documentation");
 960
 961   DEFVAR_LISP ("internal-doc-file-name", Vdoc_file_name,
 962                doc: /* Name of file containing documentation strings of built-in symbols.  */);
 963   Vdoc_file_name = Qnil;
 964
 965   DEFVAR_LISP ("build-files", Vbuild_files,
 966                doc: /* A list of files used to build this Emacs binary.  */);
 967   Vbuild_files = Qnil;
 968
 969   defsubr (&Sdocumentation);
 970   defsubr (&Sdocumentation_property);
 971   defsubr (&Ssnarf_documentation);
 972   defsubr (&Ssubstitute_command_keys);
 973 }