tagmanager/perl.c

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