1: /* Record indices of function doc strings stored in a file.
    2:    Copyright (C) 1985, 1986, 1993, 1994, 1995, 1997, 1998, 1999, 2000, 2001,
    3:                  2002, 2003, 2004, 2005, 2006, 2007 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 2, 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: 
   25: #include <sys/types.h>
   26: #include <sys/file.h>   /* Must be after sys/types.h for USG and BSD4_1*/
   27: #include <ctype.h>
   28: 
   29: #ifdef HAVE_FCNTL_H
   30: #include <fcntl.h>
   31: #endif
   32: 
   33: #ifdef HAVE_UNISTD_H
   34: #include <unistd.h>
   35: #endif
   36: 
   37: #ifndef O_RDONLY
   38: #define O_RDONLY 0
   39: #endif
   40: 
   41: #include "lisp.h"
   42: #include "buffer.h"
   43: #include "keyboard.h"
   44: #include "charset.h"
   45: #include "keymap.h"
   46: 
   47: #ifdef HAVE_INDEX
   48: extern char *index P_ ((const char *, int));
   49: #endif
   50: 
   51: Lisp_Object Vdoc_file_name;
   52: 
   53: Lisp_Object Qfunction_documentation;
   54: 
   55: /* A list of files used to build this Emacs binary.  */
   56: static Lisp_Object Vbuild_files;
   57: 
   58: extern Lisp_Object Voverriding_local_map;
   59: 
   60: extern Lisp_Object Qremap;
   61: 
   62: /* For VMS versions with limited file name syntax,
   63:    convert the name to something VMS will allow.  */
   64: static void
   65: munge_doc_file_name (name)
   66:      char *name;
   67: {
   68: #ifdef VMS
   69: #ifndef NO_HYPHENS_IN_FILENAMES
   70:   extern char * sys_translate_unix (char *ufile);
   71:   strcpy (name, sys_translate_unix (name));
   72: #else /* NO_HYPHENS_IN_FILENAMES */
   73:   char *p = name;
   74:   while (*p)
   75:     {
   76:       if (*p == '-')
   77:         *p = '_';
   78:       p++;
   79:     }
   80: #endif /* NO_HYPHENS_IN_FILENAMES */
   81: #endif /* VMS */
   82: }
   83: 
   84: /* Buffer used for reading from documentation file.  */
   85: static char *get_doc_string_buffer;
   86: static int get_doc_string_buffer_size;
   87: 
   88: static unsigned char *read_bytecode_pointer;
   89: Lisp_Object Fsnarf_documentation P_ ((Lisp_Object));
   90: 
   91: /* readchar in lread.c calls back here to fetch the next byte.
   92:    If UNREADFLAG is 1, we unread a byte.  */
   93: 
   94: int
   95: read_bytecode_char (unreadflag)
   96:      int unreadflag;
   97: {
   98:   if (unreadflag)
   99:     {
  100:       read_bytecode_pointer--;
  101:       return 0;
  102:     }
  103:   return *read_bytecode_pointer++;
  104: }
  105: 
  106: /* Extract a doc string from a file.  FILEPOS says where to get it.
  107:    If it is an integer, use that position in the standard DOC-... file.
  108:    If it is (FILE . INTEGER), use FILE as the file name
  109:    and INTEGER as the position in that file.
  110:    But if INTEGER is negative, make it positive.
  111:    (A negative integer is used for user variables, so we can distinguish
  112:    them without actually fetching the doc string.)
  113: 
  114:    If the location does not point to the beginning of a docstring
  115:    (e.g. because the file has been modified and the location is stale),
  116:    return nil.
  117: 
  118:    If UNIBYTE is nonzero, always make a unibyte string.
  119: 
  120:    If DEFINITION is nonzero, assume this is for reading
  121:    a dynamic function definition; convert the bytestring
  122:    and the constants vector with appropriate byte handling,
  123:    and return a cons cell.  */
  124: 
  125: Lisp_Object
  126: get_doc_string (filepos, unibyte, definition)
  127:      Lisp_Object filepos;
  128:      int unibyte, definition;
  129: {
  130:   char *from, *to;
  131:   register int fd;
  132:   register char *name;
  133:   register char *p, *p1;
  134:   int minsize;
  135:   int offset, position;
  136:   Lisp_Object file, tem;
  137: 
  138:   if (INTEGERP (filepos))
  139:     {
  140:       file = Vdoc_file_name;
  141:       position = XINT (filepos);
  142:     }
  143:   else if (CONSP (filepos))
  144:     {
  145:       file = XCAR (filepos);
  146:       position = XINT (XCDR (filepos));
  147:     }
  148:   else
  149:     return Qnil;
  150: 
  151:   if (position < 0)
  152:     position = - position;
  153: 
  154:   if (!STRINGP (Vdoc_directory))
  155:     return Qnil;
  156: 
  157:   if (!STRINGP (file))
  158:     return Qnil;
  159: 
  160:   /* Put the file name in NAME as a C string.
  161:      If it is relative, combine it with Vdoc_directory.  */
  162: 
  163:   tem = Ffile_name_absolute_p (file);
  164:   if (NILP (tem))
  165:     {
  166:       minsize = SCHARS (Vdoc_directory);
  167:       /* sizeof ("../etc/") == 8 */
  168:       if (minsize < 8)
  169:         minsize = 8;
  170:       name = (char *) alloca (minsize + SCHARS (file) + 8);
  171:       strcpy (name, SDATA (Vdoc_directory));
  172:       strcat (name, SDATA (file));
  173:       munge_doc_file_name (name);
  174:     }
  175:   else
  176:     {
  177:       name = (char *) SDATA (file);
  178:     }
  179: 
  180:   fd = emacs_open (name, O_RDONLY, 0);
  181:   if (fd < 0)
  182:     {
  183: #ifndef CANNOT_DUMP
  184:       if (!NILP (Vpurify_flag))
  185:         {
  186:           /* Preparing to dump; DOC file is probably not installed.
  187:              So check in ../etc. */
  188:           strcpy (name, "../etc/");
  189:           strcat (name, SDATA (file));
  190:           munge_doc_file_name (name);
  191: 
  192:           fd = emacs_open (name, O_RDONLY, 0);
  193:         }
  194: #endif
  195:       if (fd < 0)
  196:         error ("Cannot open doc string file \"%s\"", name);
  197:     }
  198: 
  199:   /* Seek only to beginning of disk block.  */
  200:   /* Make sure we read at least 1024 bytes before `position'
  201:      so we can check the leading text for consistency.  */
  202:   offset = min (position, max (1024, position % (8 * 1024)));
  203:   if (0 > lseek (fd, position - offset, 0))
  204:     {
  205:       emacs_close (fd);
  206:       error ("Position %ld out of range in doc string file \"%s\"",
  207:              position, name);
  208:     }
  209: 
  210:   /* Read the doc string into get_doc_string_buffer.
  211:      P points beyond the data just read.  */
  212: 
  213:   p = get_doc_string_buffer;
  214:   while (1)
  215:     {
  216:       int space_left = (get_doc_string_buffer_size
  217:                         - (p - get_doc_string_buffer));
  218:       int nread;
  219: 
  220:       /* Allocate or grow the buffer if we need to.  */
  221:       if (space_left == 0)
  222:         {
  223:           int in_buffer = p - get_doc_string_buffer;
  224:           get_doc_string_buffer_size += 16 * 1024;
  225:           get_doc_string_buffer
  226:             = (char *) xrealloc (get_doc_string_buffer,
  227:                                  get_doc_string_buffer_size + 1);
  228:           p = get_doc_string_buffer + in_buffer;
  229:           space_left = (get_doc_string_buffer_size
  230:                         - (p - get_doc_string_buffer));
  231:         }
  232: 
  233:       /* Read a disk block at a time.
  234:          If we read the same block last time, maybe skip this?  */
  235:       if (space_left > 1024 * 8)
  236:         space_left = 1024 * 8;
  237:       nread = emacs_read (fd, p, space_left);
  238:       if (nread < 0)
  239:         {
  240:           emacs_close (fd);
  241:           error ("Read error on documentation file");
  242:         }
  243:       p[nread] = 0;
  244:       if (!nread)
  245:         break;
  246:       if (p == get_doc_string_buffer)
  247:         p1 = (char *) index (p + offset, '\037');
  248:       else
  249:         p1 = (char *) index (p, '\037');
  250:       if (p1)
  251:         {
  252:           *p1 = 0;
  253:           p = p1;
  254:           break;
  255:         }
  256:       p += nread;
  257:     }
  258:   emacs_close (fd);
  259: 
  260:   /* Sanity checking.  */
  261:   if (CONSP (filepos))
  262:     {
  263:       int test = 1;
  264:       if (get_doc_string_buffer[offset - test++] != ' ')
  265:         return Qnil;
  266:       while (get_doc_string_buffer[offset - test] >= '0'
  267:              && get_doc_string_buffer[offset - test] <= '9')
  268:         test++;
  269:       if (get_doc_string_buffer[offset - test++] != '@'
  270:           || get_doc_string_buffer[offset - test] != '#')
  271:         return Qnil;
  272:     }
  273:   else
  274:     {
  275:       int test = 1;
  276:       if (get_doc_string_buffer[offset - test++] != '\n')
  277:         return Qnil;
  278:       while (get_doc_string_buffer[offset - test] > ' ')
  279:         test++;
  280:       if (get_doc_string_buffer[offset - test] != '\037')
  281:         return Qnil;
  282:     }
  283: 
  284:   /* Scan the text and perform quoting with ^A (char code 1).
  285:      ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_.  */
  286:   from = get_doc_string_buffer + offset;
  287:   to = get_doc_string_buffer + offset;
  288:   while (from != p)
  289:     {
  290:       if (*from == 1)
  291:         {
  292:           int c;
  293: 
  294:           from++;
  295:           c = *from++;
  296:           if (c == 1)
  297:             *to++ = c;
  298:           else if (c == '0')
  299:             *to++ = 0;
  300:           else if (c == '_')
  301:             *to++ = 037;
  302:           else
  303:             error ("Invalid data in documentation file -- ^A followed by code 0%o", c);
  304:         }
  305:       else
  306:         *to++ = *from++;
  307:     }
  308: 
  309:   /* If DEFINITION, read from this buffer
  310:      the same way we would read bytes from a file.  */
  311:   if (definition)
  312:     {
  313:       read_bytecode_pointer = get_doc_string_buffer + offset;
  314:       return Fread (Qlambda);
  315:     }
  316: 
  317:   if (unibyte)
  318:     return make_unibyte_string (get_doc_string_buffer + offset,
  319:                                 to - (get_doc_string_buffer + offset));
  320:   else
  321:     {
  322:       /* Let the data determine whether the string is multibyte,
  323:          even if Emacs is running in --unibyte mode.  */
  324:       int nchars = multibyte_chars_in_text (get_doc_string_buffer + offset,
  325:                                             to - (get_doc_string_buffer + offset));
  326:       return make_string_from_bytes (get_doc_string_buffer + offset,
  327:                                      nchars,
  328:                                      to - (get_doc_string_buffer + offset));
  329:     }
  330: }
  331: 
  332: /* Get a string from position FILEPOS and pass it through the Lisp reader.
  333:    We use this for fetching the bytecode string and constants vector
  334:    of a compiled function from the .elc file.  */
  335: 
  336: Lisp_Object
  337: read_doc_string (filepos)
  338:      Lisp_Object filepos;
  339: {
  340:   return get_doc_string (filepos, 0, 1);
  341: }
  342: 
  343: static int
  344: reread_doc_file (file)
  345:      Lisp_Object file;
  346: {
  347: #if 0
  348:   Lisp_Object reply, prompt[3];
  349:   struct gcpro gcpro1;
  350:   GCPRO1 (file);
  351:   prompt[0] = build_string ("File ");
  352:   prompt[1] = NILP (file) ? Vdoc_file_name : file;
  353:   prompt[2] = build_string (" is out of sync.  Reload? ");
  354:   reply = Fy_or_n_p (Fconcat (3, prompt));
  355:   UNGCPRO;
  356:   if (NILP (reply))
  357:     return 0;
  358: #endif
  359: 
  360:   if (NILP (file))
  361:     Fsnarf_documentation (Vdoc_file_name);
  362:   else
  363:     Fload (file, Qt, Qt, Qt, Qnil);
  364: 
  365:   return 1;
  366: }
  367: 
  368: DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
  369:        doc: /* Return the documentation string of FUNCTION.
  370: Unless a non-nil second argument RAW is given, the
  371: string is passed through `substitute-command-keys'.  */)
  372:      (function, raw)
  373:      Lisp_Object function, raw;
  374: {
  375:   Lisp_Object fun;
  376:   Lisp_Object funcar;
  377:   Lisp_Object tem, doc;
  378:   int try_reload = 1;
  379: 
  380:  documentation:
  381: 
  382:   doc = Qnil;
  383: 
  384:   if (SYMBOLP (function)
  385:       && (tem = Fget (function, Qfunction_documentation),
  386:           !NILP (tem)))
  387:     return Fdocumentation_property (function, Qfunction_documentation, raw);
  388: 
  389:   fun = Findirect_function (function, Qnil);
  390:   if (SUBRP (fun))
  391:     {
  392:       if (XSUBR (fun)->doc == 0)
  393:         return Qnil;
  394:       else if ((EMACS_INT) XSUBR (fun)->doc >= 0)
  395:         doc = build_string (XSUBR (fun)->doc);
  396:       else
  397:         doc = make_number ((EMACS_INT) XSUBR (fun)->doc);
  398:     }
  399:   else if (COMPILEDP (fun))
  400:     {
  401:       if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) <= COMPILED_DOC_STRING)
  402:         return Qnil;
  403:       tem = AREF (fun, COMPILED_DOC_STRING);
  404:       if (STRINGP (tem))
  405:         doc = tem;
  406:       else if (NATNUMP (tem) || CONSP (tem))
  407:         doc = tem;
  408:       else
  409:         return Qnil;
  410:     }
  411:   else if (STRINGP (fun) || VECTORP (fun))
  412:     {
  413:       return build_string ("Keyboard macro.");
  414:     }
  415:   else if (CONSP (fun))
  416:     {
  417:       funcar = Fcar (fun);
  418:       if (!SYMBOLP (funcar))
  419:         xsignal1 (Qinvalid_function, fun);
  420:       else if (EQ (funcar, Qkeymap))
  421:         return build_string ("Prefix command (definition is a keymap associating keystrokes with commands).");
  422:       else if (EQ (funcar, Qlambda)
  423:                || EQ (funcar, Qautoload))
  424:         {
  425:           Lisp_Object tem1;
  426:           tem1 = Fcdr (Fcdr (fun));
  427:           tem = Fcar (tem1);
  428:           if (STRINGP (tem))
  429:             doc = tem;
  430:           /* Handle a doc reference--but these never come last
  431:              in the function body, so reject them if they are last.  */
  432:           else if ((NATNUMP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
  433:                    && !NILP (XCDR (tem1)))
  434:             doc = tem;
  435:           else
  436:             return Qnil;
  437:         }
  438:       else if (EQ (funcar, Qmacro))
  439:         return Fdocumentation (Fcdr (fun), raw);
  440:       else
  441:         goto oops;
  442:     }
  443:   else
  444:     {
  445:     oops:
  446:       xsignal1 (Qinvalid_function, fun);
  447:     }
  448: 
  449:   /* If DOC is 0, it's typically because of a dumped file missing
  450:      from the DOC file (bug in src/Makefile.in).  */
  451:   if (EQ (doc, make_number (0)))
  452:     doc = Qnil;
  453:   if (INTEGERP (doc) || CONSP (doc))
  454:     {
  455:       Lisp_Object tem;
  456:       tem = get_doc_string (doc, 0, 0);
  457:       if (NILP (tem) && try_reload)
  458:         {
  459:           /* The file is newer, we need to reset the pointers.  */
  460:           struct gcpro gcpro1, gcpro2;
  461:           GCPRO2 (function, raw);
  462:           try_reload = reread_doc_file (Fcar_safe (doc));
  463:           UNGCPRO;
  464:           if (try_reload)
  465:             {
  466:               try_reload = 0;
  467:               goto documentation;
  468:             }
  469:         }
  470:       else
  471:         doc = tem;
  472:     }
  473: 
  474:   if (NILP (raw))
  475:     doc = Fsubstitute_command_keys (doc);
  476:   return doc;
  477: }
  478: 
  479: DEFUN ("documentation-property", Fdocumentation_property,
  480:        Sdocumentation_property, 2, 3, 0,
  481:        doc: /* Return the documentation string that is SYMBOL's PROP property.
  482: Third argument RAW omitted or nil means pass the result through
  483: `substitute-command-keys' if it is a string.
  484: 
  485: This differs from `get' in that it can refer to strings stored in the
  486: `etc/DOC' file; and that it evaluates documentation properties that
  487: aren't strings.  */)
  488:   (symbol, prop, raw)
  489:      Lisp_Object symbol, prop, raw;
  490: {
  491:   int try_reload = 1;
  492:   Lisp_Object tem;
  493: 
  494:  documentation_property:
  495: 
  496:   tem = Fget (symbol, prop);
  497:   if (EQ (tem, make_number (0)))
  498:     tem = Qnil;
  499:   if (INTEGERP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
  500:     {
  501:       Lisp_Object doc = tem;
  502:       tem = get_doc_string (tem, 0, 0);
  503:       if (NILP (tem) && try_reload)
  504:         {
  505:           /* The file is newer, we need to reset the pointers.  */
  506:           struct gcpro gcpro1, gcpro2, gcpro3;
  507:           GCPRO3 (symbol, prop, raw);
  508:           try_reload = reread_doc_file (Fcar_safe (doc));
  509:           UNGCPRO;
  510:           if (try_reload)
  511:             {
  512:               try_reload = 0;
  513:               goto documentation_property;
  514:             }
  515:         }
  516:     }
  517:   else if (!STRINGP (tem))
  518:     /* Feval protects its argument.  */
  519:     tem = Feval (tem);
  520: 
  521:   if (NILP (raw) && STRINGP (tem))
  522:     tem = Fsubstitute_command_keys (tem);
  523:   return tem;
  524: }
  525: ^L
  526: /* Scanning the DOC files and placing docstring offsets into functions.  */
  527: 
  528: static void
  529: store_function_docstring (fun, offset)
  530:      Lisp_Object fun;
  531:      /* Use EMACS_INT because we get this from pointer subtraction.  */
  532:      EMACS_INT offset;
  533: {
  534:   fun = indirect_function (fun);
  535: 
  536:   /* The type determines where the docstring is stored.  */
  537: 
  538:   /* Lisp_Subrs have a slot for it.  */
  539:   if (SUBRP (fun))
  540:     XSUBR (fun)->doc = (char *) - offset;
  541: 
  542:   /* If it's a lisp form, stick it in the form.  */
  543:   else if (CONSP (fun))
  544:     {
  545:       Lisp_Object tem;
  546: 
  547:       tem = XCAR (fun);
  548:       if (EQ (tem, Qlambda) || EQ (tem, Qautoload))
  549:         {
  550:           tem = Fcdr (Fcdr (fun));
  551:           if (CONSP (tem) && INTEGERP (XCAR (tem)))
  552:             XSETCARFASTINT (tem, offset);
  553:         }
  554:       else if (EQ (tem, Qmacro))
  555:         store_function_docstring (XCDR (fun), offset);
  556:     }
  557: 
  558:   /* Bytecode objects sometimes have slots for it.  */
  559:   else if (COMPILEDP (fun))
  560:     {
  561:       /* This bytecode object must have a slot for the
  562:          docstring, since we've found a docstring for it.  */
  563:       if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING)
  564:         XSETFASTINT (AREF (fun, COMPILED_DOC_STRING), offset);
  565:     }
  566: }
  567: 
  568: 
  569: DEFUN ("Snarf-documentation", Fsnarf_documentation, Ssnarf_documentation,
  570:        1, 1, 0,
  571:        doc: /* Used during Emacs initialization to scan the `etc/DOC...' file.
  572: This searches the `etc/DOC...' file for doc strings and
  573: records them in function and variable definitions.
  574: The function takes one argument, FILENAME, a string;
  575: it specifies the file name (without a directory) of the DOC file.
  576: That file is found in `../etc' now; later, when the dumped Emacs is run,
  577: the same file name is found in the `doc-directory'.  */)
  578:      (filename)
  579:      Lisp_Object filename;
  580: {
  581:   int fd;
  582:   char buf[1024 + 1];
  583:   register int filled;
  584:   register int pos;
  585:   register char *p, *end;
  586:   Lisp_Object sym;
  587:   char *name;
  588:   int skip_file = 0;
  589: 
  590:   CHECK_STRING (filename);
  591: 
  592:   if
  593: #ifndef CANNOT_DUMP
  594:     (!NILP (Vpurify_flag))
  595: #else /* CANNOT_DUMP */
  596:       (0)
  597: #endif /* CANNOT_DUMP */
  598:     {
  599:       name = (char *) alloca (SCHARS (filename) + 14);
  600:       strcpy (name, "../etc/");
  601:     }
  602:   else
  603:     {
  604:       CHECK_STRING (Vdoc_directory);
  605:       name = (char *) alloca (SCHARS (filename)
  606:                           + SCHARS (Vdoc_directory) + 1);
  607:       strcpy (name, SDATA (Vdoc_directory));
  608:     }
  609:   strcat (name, SDATA (filename));      /*** Add this line ***/
  610:   munge_doc_file_name (name);
  611: 
  612:   /* Vbuild_files is nil when temacs is run, and non-nil after that.  */
  613:   if (NILP (Vbuild_files))
  614:   {
  615:     size_t cp_size = 0;
  616:     size_t to_read;
  617:     int nr_read;
  618:     char *cp = NULL;
  619:     char *beg, *end;