4 * Copyright (c) 2000-2003, Darren Hiebert
6 * This source code is released for free distribution under the terms of the
7 * GNU General Public License.
9 * This module contains functions for generating tags for PERL language
16 #include "general.h" /* must always come first */
26 #define TRACE_PERL_C 0
27 #define TRACE if (TRACE_PERL_C) printf("perl.c:%d: ", __LINE__), printf
39 K_SUBROUTINE_DECLARATION
42 static kindOption PerlKinds
[] = {
43 { TRUE
, 'e', "enum", "constants" },
44 { TRUE
, 'o', "other", "formats" },
45 { TRUE
, 'm', "macro", "labels" },
46 { TRUE
, 'p', "package", "packages" },
47 { TRUE
, 'f', "function", "subroutines" },
48 { FALSE
, 'p', "prototype", "subroutine declarations" },
52 * FUNCTION DEFINITIONS
55 static boolean
isIdentifier1 (int c
)
57 return (boolean
) (isalpha (c
) || c
== '_');
60 static boolean
isIdentifier (int c
)
62 return (boolean
) (isalnum (c
) || c
== '_');
65 static boolean
isPodWord (const char *word
)
67 boolean result
= FALSE
;
70 const char *const pods
[] = {
71 "head1", "head2", "head3", "head4", "over", "item", "back",
72 "pod", "begin", "end", "for"
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);
79 strncpy (id
, word
, len
);
81 for (i
= 0 ; i
< count
&& ! result
; ++i
)
83 if (strcmp (id
, pods
[i
]) == 0)
92 * Perl subroutine declaration may look like one of the following:
97 * sub abc (proto) :attr;
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
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.
109 * If we can't determine what this is (due to a file ending, for example),
110 * we will return FALSE.
112 static boolean
isSubroutineDeclaration (const unsigned char *cp
)
114 boolean attr
= FALSE
;
124 else if (TRUE
== attr
)
125 return FALSE
; /* Invalid attribute name */
146 if (isIdentifier1(*cp
)) {
148 while (isIdentifier (*cp
))
151 goto SUB_DECL_SWITCH
; /* Instead of --cp; */
155 } else if (nparens
) {
162 } while (NULL
!= (cp
= fileReadLine ()));
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{ (]+/
171 static void findPerlTags (void)
173 vString
*name
= vStringNew ();
174 vString
*package
= NULL
;
175 boolean skipPodDoc
= FALSE
;
176 const unsigned char *line
;
178 while ((line
= fileReadLine ()) != NULL
)
180 boolean spaceRequired
= FALSE
;
181 boolean qualified
= FALSE
;
182 const unsigned char *cp
= line
;
183 perlKind kind
= K_NONE
;
188 if (strncmp ((const char*) line
, "=cut", (size_t) 4) == 0)
192 else if (line
[0] == '=')
194 skipPodDoc
= isPodWord ((const char*)line
+ 1);
197 else if (strcmp ((const char*) line
, "__DATA__") == 0)
199 else if (strcmp ((const char*) line
, "__END__") == 0)
201 else if (line
[0] == '#')
204 while (isspace (*cp
))
207 if (strncmp((const char*) cp
, "sub", (size_t) 3) == 0)
209 TRACE("this looks like a sub\n");
212 spaceRequired
= TRUE
;
215 else if (strncmp((const char*) cp
, "use", (size_t) 3) == 0)
220 while (*cp
&& isspace (*cp
))
222 if (strncmp((const char*) cp
, "constant", (size_t) 8) != 0)
226 spaceRequired
= TRUE
;
229 else if (strncmp((const char*) cp
, "package", (size_t) 7) == 0)
231 /* This will point to space after 'package' so that a tag
233 const unsigned char *space
= cp
+= 7;
236 package
= vStringNew ();
238 vStringClear (package
);
239 while (isspace (*cp
))
241 while ((int) *cp
!= ';' && !isspace ((int) *cp
))
243 vStringPut (package
, (int) *cp
);
246 vStringCatS (package
, "::");
248 cp
= space
; /* Rewind */
250 spaceRequired
= TRUE
;
253 else if (strncmp((const char*) cp
, "format", (size_t) 6) == 0)
257 spaceRequired
= TRUE
;
262 if (isIdentifier1 (*cp
))
264 const unsigned char *p
= cp
;
265 while (isIdentifier (*p
))
269 if ((int) *p
== ':' && (int) *(p
+ 1) != ':')
275 TRACE("cp0: %s\n", (const char *) cp
);
276 if (spaceRequired
&& *cp
&& !isspace (*cp
))
279 TRACE("cp1: %s\n", (const char *) cp
);
280 while (isspace (*cp
))
283 while (!*cp
|| '#' == *cp
) { /* Gobble up empty lines
285 cp
= fileReadLine ();
288 while (isspace (*cp
))
292 while (isIdentifier (*cp
) || (K_PACKAGE
== kind
&& ':' == *cp
))
294 vStringPut (name
, (int) *cp
);
298 if (K_FORMAT
== kind
&&
299 vStringLength (name
) == 0 && /* cp did not advance */
302 /* format's name is optional. If it's omitted, 'STDOUT'
304 vStringCatS (name
, "STDOUT");
307 vStringTerminate (name
);
308 TRACE("name: %s\n", name
->buffer
);
310 if (0 == vStringLength(name
)) {
315 if (K_SUBROUTINE
== kind
)
318 * isSubroutineDeclaration() may consume several lines. So
319 * we record line positions.
321 initTagEntry(&e
, vStringValue(name
));
323 if (TRUE
== isSubroutineDeclaration(cp
)) {
324 if (TRUE
== PerlKinds
[K_SUBROUTINE_DECLARATION
].enabled
) {
325 kind
= K_SUBROUTINE_DECLARATION
;
332 e
.kind
= PerlKinds
[kind
].letter
;
333 e
.kindName
= PerlKinds
[kind
].name
;
337 if (Option
.include
.qualifiedTags
&& qualified
&&
338 package
!= NULL
&& vStringLength (package
) > 0)
340 vString
*const qualifiedName
= vStringNew ();
341 vStringCopy (qualifiedName
, package
);
342 vStringCat (qualifiedName
, name
);
343 e
.name
= vStringValue(qualifiedName
);
345 vStringDelete (qualifiedName
);
347 } else if (vStringLength (name
) > 0)
349 makeSimpleTag (name
, PerlKinds
, kind
);
350 if (Option
.include
.qualifiedTags
&& qualified
&&
352 package
!= NULL
&& vStringLength (package
) > 0)
354 vString
*const qualifiedName
= vStringNew ();
355 vStringCopy (qualifiedName
, package
);
356 vStringCat (qualifiedName
, name
);
357 makeSimpleTag (qualifiedName
, PerlKinds
, kind
);
358 vStringDelete (qualifiedName
);
366 vStringDelete (name
);
368 vStringDelete (package
);
371 extern parserDefinition
* PerlParser (void)
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
;
382 /* vi:set tabstop=4 shiftwidth=4 noexpandtab: */