perl.c

   1 /*
   2 *   $Id: perl.c 601 2007-08-02 04:45:16Z perlguy0 $
   3 *
   4 *   Copyright (c) 2000-2003, Darren Hiebert
   5 *
   6 *   This source code is released for free distribution under the terms of the
   7 *   GNU General Public License.
   8 *
   9 *   This module contains functions for generating tags for PERL language
  10 *   files.
  11 */
  12
  13 /*
  14 *   INCLUDE FILES
  15 */
  16 #include "general.h"  /* must always come first */
  17
  18 #include <string.h>
  19
  20 #include "entry.h"
  21 #include "options.h"
  22 #include "read.h"
  23 #include "routines.h"
  24 #include "vstring.h"
  25
  26 #define TRACE_PERL_C 0
  27 #define TRACE if (TRACE_PERL_C) printf("perl.c:%d: ", __LINE__), printf
  28
  29 /*
  30 *   DATA DEFINITIONS
  31 */
  32 typedef enum {
  33         K_NONE = -1,
  34         K_CONSTANT,
  35         K_FORMAT,
  36         K_LABEL,
  37         K_PACKAGE,
  38         K_SUBROUTINE,
  39         K_SUBROUTINE_DECLARATION
  40 } perlKind;
  41
  42 static kindOption PerlKinds [] = {
  43         { TRUE,  'c', "constant",               "constants" },
  44         { TRUE,  'f', "format",                 "formats" },
  45         { TRUE,  'l', "label",                  "labels" },
  46         { TRUE,  'p', "package",                "packages" },
  47         { TRUE,  's', "subroutine",             "subroutines" },
  48         { FALSE, 'd', "subroutine declaration", "subroutine declarations" },
  49 };
  50
  51 /*
  52 *   FUNCTION DEFINITIONS
  53 */
  54
  55 static boolean isIdentifier1 (int c)
  56 {
  57         return (boolean) (isalpha (c) || c == '_');
  58 }
  59
  60 static boolean isIdentifier (int c)
  61 {
  62         return (boolean) (isalnum (c) || c == '_');
  63 }
  64
  65 static boolean isPodWord (const char *word)
  66 {
  67         boolean result = FALSE;
  68         if (isalpha (*word))
  69         {
  70                 const char *const pods [] = {
  71                         "head1", "head2", "head3", "head4", "over", "item", "back",
  72                         "pod", "begin", "end", "for"
  73                 };
  74                 const size_t count = sizeof (pods) / sizeof (pods [0]);
  75                 const char *white = strpbrk (word, " \t");
  76                 const size_t len = (white!=NULL) ? (size_t)(white-word) : strlen (word);
  77                 char *const id = (char*) eMalloc (len + 1);
  78                 size_t i;
  79                 strncpy (id, word, len);
  80                 id [len] = '\0';
  81                 for (i = 0  ;  i < count  &&  ! result  ;  ++i)
  82                 {
  83                         if (strcmp (id, pods [i]) == 0)
  84                                 result = TRUE;
  85                 }
  86                 eFree (id);
  87         }
  88         return result;
  89 }
  90
  91 /*
  92  * Perl subroutine declaration may look like one of the following:
  93  *
  94  *  sub abc;
  95  *  sub abc :attr;
  96  *  sub abc (proto);
  97  *  sub abc (proto) :attr;
  98  *
  99  * Note that there may be more than one attribute.  Attributes may
 100  * have things in parentheses (they look like arguments).  Anything
 101  * inside of those parentheses goes.  Prototypes may contain semi-colons.
 102  * The matching end when we encounter (outside of any parentheses) either
 103  * a semi-colon (that'd be a declaration) or an left curly brace
 104  * (definition).
 105  *
 106  * This is pretty complicated parsing (plus we all know that only perl can
 107  * parse Perl), so we are only promising best effort here.
 108  *
 109  * If we can't determine what this is (due to a file ending, for example),
 110  * we will return FALSE.
 111  */
 112 static boolean isSubroutineDeclaration (const unsigned char *cp)
 113 {
 114         boolean attr = FALSE;
 115         int nparens = 0;
 116
 117         do {
 118                 for ( ; *cp; ++cp) {
 119 SUB_DECL_SWITCH:
 120                         switch (*cp) {
 121                                 case ':':
 122                                         if (nparens)
 123                                                 break;
 124                                         else if (TRUE == attr)
 125                                                 return FALSE;    /* Invalid attribute name */
 126                                         else
 127                                                 attr = TRUE;
 128                                         break;
 129                                 case '(':
 130                                         ++nparens;
 131                                         break;
 132                                 case ')':
 133                                         --nparens;
 134                                         break;
 135                                 case ' ':
 136                                 case '\t':
 137                                         break;
 138                                 case ';':
 139                                         if (!nparens)
 140                                                 return TRUE;
 141                                 case '{':
 142                                         if (!nparens)
 143                                                 return FALSE;
 144                                 default:
 145                                         if (attr) {
 146                                                 if (isIdentifier1(*cp)) {
 147                                                         cp++;
 148                                                         while (isIdentifier (*cp))
 149                                                                 cp++;
 150                                                         attr = FALSE;
 151                                                         goto SUB_DECL_SWITCH; /* Instead of --cp; */
 152                                                 } else {
 153                                                         return FALSE;
 154                                                 }
 155                                         } else if (nparens) {
 156                                                 break;
 157                                         } else {
 158                                                 return FALSE;
 159                                         }
 160                         }
 161                 }
 162         } while (NULL != (cp = fileReadLine ()));
 163
 164         return FALSE;
 165 }
 166
 167 /* Algorithm adapted from from GNU etags.
 168  * Perl support by Bart Robinson <lomew@cs.utah.edu>
 169  * Perl sub names: look for /^ [ \t\n]sub [ \t\n]+ [^ \t\n{ (]+/
 170  */
 171 static void findPerlTags (void)
 172 {
 173         vString *name = vStringNew ();
 174         vString *package = NULL;
 175         boolean skipPodDoc = FALSE;
 176         const unsigned char *line;
 177
 178         while ((line = fileReadLine ()) != NULL)
 179         {
 180                 boolean spaceRequired = FALSE;
 181                 boolean qualified = FALSE;
 182                 const unsigned char *cp = line;
 183                 perlKind kind = K_NONE;
 184                 tagEntryInfo e;
 185
 186                 if (skipPodDoc)
 187                 {
 188                         if (strncmp ((const char*) line, "=cut", (size_t) 4) == 0)
 189                                 skipPodDoc = FALSE;
 190                         continue;
 191                 }
 192                 else if (line [0] == '=')
 193                 {
 194                         skipPodDoc = isPodWord ((const char*)line + 1);
 195                         continue;
 196                 }
 197                 else if (strcmp ((const char*) line, "__DATA__") == 0)
 198                         break;
 199                 else if (strcmp ((const char*) line, "__END__") == 0)
 200                         break;
 201                 else if (line [0] == '#')
 202                         continue;
 203
 204                 while (isspace (*cp))
 205                         cp++;
 206
 207                 if (strncmp((const char*) cp, "sub", (size_t) 3) == 0)
 208                 {
 209                         TRACE("this looks like a sub\n");
 210                         cp += 3;
 211                         kind = K_SUBROUTINE;
 212                         spaceRequired = TRUE;
 213                         qualified = TRUE;
 214                 }
 215                 else if (strncmp((const char*) cp, "use", (size_t) 3) == 0)
 216                 {
 217                         cp += 3;
 218                         if (!isspace(*cp))
 219                                 continue;
 220                         while (*cp && isspace (*cp))
 221                                 ++cp;
 222                         if (strncmp((const char*) cp, "constant", (size_t) 8) != 0)
 223                                 continue;
 224                         cp += 8;
 225                         kind = K_CONSTANT;
 226                         spaceRequired = TRUE;
 227                         qualified = TRUE;
 228                 }
 229                 else if (strncmp((const char*) cp, "package", (size_t) 7) == 0)
 230                 {
 231                         /* This will point to space after 'package' so that a tag
 232                            can be made */
 233                         const unsigned char *space = cp += 7;
 234
 235                         if (package == NULL)
 236                                 package = vStringNew ();
 237                         else
 238                                 vStringClear (package);
 239                         while (isspace (*cp))
 240                                 cp++;
 241                         while ((int) *cp != ';'  &&  !isspace ((int) *cp))
 242                         {
 243                                 vStringPut (package, (int) *cp);
 244                                 cp++;
 245                         }
 246                         vStringCatS (package, "::");
 247
 248                         cp = space;      /* Rewind */
 249                         kind = K_PACKAGE;
 250                         spaceRequired = TRUE;
 251                         qualified = TRUE;
 252                 }
 253                 else if (strncmp((const char*) cp, "format", (size_t) 6) == 0)
 254                 {
 255                         cp += 6;
 256                         kind = K_FORMAT;
 257                         spaceRequired = TRUE;
 258                         qualified = TRUE;
 259                 }
 260                 else
 261                 {
 262                         if (isIdentifier1 (*cp))
 263                         {
 264                                 const unsigned char *p = cp;
 265                                 while (isIdentifier (*p))
 266                                         ++p;
 267                                 while (isspace (*p))
 268                                         ++p;
 269                                 if ((int) *p == ':' && (int) *(p + 1) != ':')
 270                                         kind = K_LABEL;
 271                         }
 272                 }
 273                 if (kind != K_NONE)
 274                 {
 275                         TRACE("cp0: %s\n", (const char *) cp);
 276                         if (spaceRequired && *cp && !isspace (*cp))
 277                                 continue;
 278
 279                         TRACE("cp1: %s\n", (const char *) cp);
 280                         while (isspace (*cp))
 281                                 cp++;
 282
 283                         while (!*cp || '#' == *cp) { /* Gobble up empty lines
 284                                                             and comments */
 285                                 cp = fileReadLine ();
 286                                 if (!cp)
 287                                         goto END_MAIN_WHILE;
 288                                 while (isspace (*cp))
 289                                         cp++;
 290                         }
 291
 292                         while (isIdentifier (*cp) || (K_PACKAGE == kind && ':' == *cp))
 293                         {
 294                                 vStringPut (name, (int) *cp);
 295                                 cp++;
 296                         }
 297
 298                         if (K_FORMAT == kind &&
 299                                 vStringLength (name) == 0 && /* cp did not advance */
 300                                 '=' == *cp)
 301                         {
 302                                 /* format's name is optional.  If it's omitted, 'STDOUT'
 303                                    is assumed. */
 304                                 vStringCatS (name, "STDOUT");
 305                         }
 306
 307                         vStringTerminate (name);
 308                         TRACE("name: %s\n", name->buffer);
 309
 310                         if (0 == vStringLength(name)) {
 311                                 vStringClear(name);
 312                                 continue;
 313                         }
 314
 315                         if (K_SUBROUTINE == kind)
 316                         {
 317                                 /*
 318                                  * isSubroutineDeclaration() may consume several lines.  So
 319                                  * we record line positions.
 320                                  */
 321                                 initTagEntry(&e, vStringValue(name));
 322
 323                                 if (TRUE == isSubroutineDeclaration(cp)) {
 324                                         if (TRUE == PerlKinds[K_SUBROUTINE_DECLARATION].enabled) {
 325                                                 kind = K_SUBROUTINE_DECLARATION;
 326                                         } else {
 327                                                 vStringClear (name);
 328                                                 continue;
 329                                         }
 330                                 }
 331
 332                                 e.kind     = PerlKinds[kind].letter;
 333                                 e.kindName = PerlKinds[kind].name;
 334
 335                                 makeTagEntry(&e);
 336
 337                                 if (Option.include.qualifiedTags && qualified &&
 338                                         package != NULL  && vStringLength (package) > 0)
 339                                 {
 340                                         vString *const qualifiedName = vStringNew ();
 341                                         vStringCopy (qualifiedName, package);
 342                                         vStringCat (qualifiedName, name);
 343                                         e.name = vStringValue(qualifiedName);
 344                                         makeTagEntry(&e);
 345                                         vStringDelete (qualifiedName);
 346                                 }
 347                         } else if (vStringLength (name) > 0)
 348                         {
 349                                 makeSimpleTag (name, PerlKinds, kind);
 350                                 if (Option.include.qualifiedTags && qualified &&
 351                                         K_PACKAGE != kind &&
 352                                         package != NULL  && vStringLength (package) > 0)
 353                                 {
 354                                         vString *const qualifiedName = vStringNew ();
 355                                         vStringCopy (qualifiedName, package);
 356                                         vStringCat (qualifiedName, name);
 357                                         makeSimpleTag (qualifiedName, PerlKinds, kind);
 358                                         vStringDelete (qualifiedName);
 359                                 }
 360                         }
 361                         vStringClear (name);
 362                 }
 363         }
 364
 365 END_MAIN_WHILE:
 366         vStringDelete (name);
 367         if (package != NULL)
 368                 vStringDelete (package);
 369 }
 370
 371 extern parserDefinition* PerlParser (void)
 372 {
 373         static const char *const extensions [] = { "pl", "pm", "plx", "perl", NULL };
 374         parserDefinition* def = parserNew ("Perl");
 375         def->kinds      = PerlKinds;
 376         def->kindCount  = KIND_COUNT (PerlKinds);
 377         def->extensions = extensions;
 378         def->parser     = findPerlTags;
 379         return def;
 380 }
 381
 382 /* vi:set tabstop=4 shiftwidth=4 noexpandtab: */