ctags/parsers/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 version 2 or (at your option) any later version.
   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 #include "debug.h"
  16
  17 #include <string.h>
  18
  19 #include "entry.h"
  20 #include "options.h"
  21 #include "read.h"
  22 #include "routines.h"
  23 #include "vstring.h"
  24 #include "xtag.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', "subroutineDeclaration",  "subroutine declarations" },
  49 };
  50
  51 /*
  52 *   FUNCTION DEFINITIONS
  53 */
  54
  55 static bool isIdentifier1 (int c)
  56 {
  57         return (bool) (isalpha (c) || c == '_');
  58 }
  59
  60 static bool isIdentifier (int c)
  61 {
  62         return (bool) (isalnum (c) || c == '_');
  63 }
  64
  65 static bool isPodWord (const char *word)
  66 {
  67         bool 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 = ARRAY_SIZE (pods);
  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 bool isSubroutineDeclaration (const unsigned char *cp)
 113 {
 114         bool 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                                         /* fall through */
 142                                 case '{':
 143                                         if (!nparens)
 144                                                 return false;
 145                                         /* fall through */
 146                                 default:
 147                                         if (attr) {
 148                                                 if (isIdentifier1(*cp)) {
 149                                                         cp++;
 150                                                         while (isIdentifier (*cp))
 151                                                                 cp++;
 152                                                         attr = false;
 153                                                         goto SUB_DECL_SWITCH; /* Instead of --cp; */
 154                                                 } else {
 155                                                         return false;
 156                                                 }
 157                                         } else if (nparens) {
 158                                                 break;
 159                                         } else {
 160                                                 return false;
 161                                         }
 162                         }
 163                 }
 164         } while (NULL != (cp = readLineFromInputFile ()));
 165
 166         return false;
 167 }
 168
 169 /* Algorithm adapted from from GNU etags.
 170  * Perl support by Bart Robinson <lomew@cs.utah.edu>
 171  * Perl sub names: look for /^ [ \t\n]sub [ \t\n]+ [^ \t\n{ (]+/
 172  */
 173 static void findPerlTags (void)
 174 {
 175         vString *name = vStringNew ();
 176         vString *package = NULL;
 177         bool skipPodDoc = false;
 178         const unsigned char *line;
 179
 180         while ((line = readLineFromInputFile ()) != NULL)
 181         {
 182                 bool spaceRequired = false;
 183                 bool qualified = false;
 184                 const unsigned char *cp = line;
 185                 perlKind kind = K_NONE;
 186                 tagEntryInfo e;
 187
 188                 if (skipPodDoc)
 189                 {
 190                         if (strncmp ((const char*) line, "=cut", (size_t) 4) == 0)
 191                                 skipPodDoc = false;
 192                         continue;
 193                 }
 194                 else if (line [0] == '=')
 195                 {
 196                         skipPodDoc = isPodWord ((const char*)line + 1);
 197                         continue;
 198                 }
 199                 else if (strcmp ((const char*) line, "__DATA__") == 0)
 200                         break;
 201                 else if (strcmp ((const char*) line, "__END__") == 0)
 202                         break;
 203                 else if (line [0] == '#')
 204                         continue;
 205
 206                 while (isspace (*cp))
 207                         cp++;
 208
 209                 if (strncmp((const char*) cp, "sub", (size_t) 3) == 0)
 210                 {
 211                         TRACE("this looks like a sub\n");
 212                         cp += 3;
 213                         kind = K_SUBROUTINE;
 214                         spaceRequired = true;
 215                         qualified = true;
 216                 }
 217                 else if (strncmp((const char*) cp, "use", (size_t) 3) == 0)
 218                 {
 219                         cp += 3;
 220                         if (!isspace(*cp))
 221                                 continue;
 222                         while (*cp && isspace (*cp))
 223                                 ++cp;
 224                         if (strncmp((const char*) cp, "constant", (size_t) 8) != 0)
 225                                 continue;
 226                         cp += 8;
 227                         kind = K_CONSTANT;
 228                         spaceRequired = true;
 229                         qualified = true;
 230                 }
 231                 else if (strncmp((const char*) cp, "package", (size_t) 7) == 0)
 232                 {
 233                         /* This will point to space after 'package' so that a tag
 234                            can be made */
 235                         const unsigned char *space = cp += 7;
 236
 237                         if (package == NULL)
 238                                 package = vStringNew ();
 239                         else
 240                                 vStringClear (package);
 241                         while (isspace (*cp))
 242                                 cp++;
 243                         while ((int) *cp != ';'  &&  !isspace ((int) *cp))
 244                         {
 245                                 vStringPut (package, (int) *cp);
 246                                 cp++;
 247                         }
 248                         vStringCatS (package, "::");
 249
 250                         cp = space;      /* Rewind */
 251                         kind = K_PACKAGE;
 252                         spaceRequired = true;
 253                         qualified = true;
 254                 }
 255                 else if (strncmp((const char*) cp, "format", (size_t) 6) == 0)
 256                 {
 257                         cp += 6;
 258                         kind = K_FORMAT;
 259                         spaceRequired = true;
 260                         qualified = true;
 261                 }
 262                 else
 263                 {
 264                         if (isIdentifier1 (*cp))
 265                         {
 266                                 const unsigned char *p = cp;
 267                                 while (isIdentifier (*p))
 268                                         ++p;
 269                                 while (isspace (*p))
 270                                         ++p;
 271                                 if ((int) *p == ':' && (int) *(p + 1) != ':')
 272                                         kind = K_LABEL;
 273                         }
 274                 }
 275                 if (kind != K_NONE)
 276                 {
 277                         TRACE("cp0: %s\n", (const char *) cp);
 278                         if (spaceRequired && *cp && !isspace (*cp))
 279                                 continue;
 280
 281                         TRACE("cp1: %s\n", (const char *) cp);
 282                         while (isspace (*cp))
 283                                 cp++;
 284
 285                         while (!*cp || '#' == *cp) { /* Gobble up empty lines
 286                                                             and comments */
 287                                 cp = readLineFromInputFile ();
 288                                 if (!cp)
 289                                         goto END_MAIN_WHILE;
 290                                 while (isspace (*cp))
 291                                         cp++;
 292                         }
 293
 294                         while (isIdentifier (*cp) || (K_PACKAGE == kind && ':' == *cp))
 295                         {
 296                                 vStringPut (name, (int) *cp);
 297                                 cp++;
 298                         }
 299
 300                         if (K_FORMAT == kind &&
 301                                 vStringLength (name) == 0 && /* cp did not advance */
 302                                 '=' == *cp)
 303                         {
 304                                 /* format's name is optional.  If it's omitted, 'STDOUT'
 305                                    is assumed. */
 306                                 vStringCatS (name, "STDOUT");
 307                         }
 308
 309                         TRACE("name: %s\n", name->buffer);
 310
 311                         if (0 == vStringLength(name)) {
 312                                 vStringClear(name);
 313                                 continue;
 314                         }
 315
 316                         if (K_SUBROUTINE == kind)
 317                         {
 318                                 /*
 319                                  * isSubroutineDeclaration() may consume several lines.  So
 320                                  * we record line positions.
 321                                  */
 322                                 initTagEntry(&e, vStringValue(name), &(PerlKinds[kind]));
 323
 324                                 if (true == isSubroutineDeclaration(cp)) {
 325                                         if (true == PerlKinds[K_SUBROUTINE_DECLARATION].enabled) {
 326                                                 kind = K_SUBROUTINE_DECLARATION;
 327                                         } else {
 328                                                 vStringClear (name);
 329                                                 continue;
 330                                         }
 331                                 }
 332
 333                                 makeTagEntry(&e);
 334
 335                                 if (isXtagEnabled(XTAG_QUALIFIED_TAGS) && 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 (isXtagEnabled(XTAG_QUALIFIED_TAGS) && 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  = ARRAY_SIZE (PerlKinds);
 375         def->extensions = extensions;
 376         def->parser     = findPerlTags;
 377         return def;
 378 }