2 * Copyright (c) 2000-2003, Darren Hiebert
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.
7 * This module contains functions for generating tags for PERL language
14 #include "general.h" /* must always come first */
27 #define TRACE_PERL_C 0
28 #define TRACE if (TRACE_PERL_C) printf("perl.c:%d: ", __LINE__), printf
40 K_SUBROUTINE_DECLARATION
43 static kindDefinition PerlKinds
[] = {
44 { true, 'c', "constant", "constants" },
45 { true, 'f', "format", "formats" },
46 { true, 'l', "label", "labels" },
47 { true, 'p', "package", "packages" },
48 { true, 's', "subroutine", "subroutines" },
49 { false, 'd', "subroutineDeclaration", "subroutine declarations" },
53 * FUNCTION DEFINITIONS
56 static bool isIdentifier1 (int c
)
58 return (bool) (isalpha (c
) || c
== '_');
61 static bool isIdentifier (int c
)
63 return (bool) (isalnum (c
) || c
== '_');
66 static bool isPodWord (const char *word
)
71 const char *const pods
[] = {
72 "head1", "head2", "head3", "head4", "over", "item", "back",
73 "pod", "begin", "end", "for"
75 const size_t count
= ARRAY_SIZE (pods
);
76 const char *white
= strpbrk (word
, " \t");
77 const size_t len
= (white
!=NULL
) ? (size_t)(white
-word
) : strlen (word
);
78 char *const id
= (char*) eMalloc (len
+ 1);
80 strncpy (id
, word
, len
);
82 for (i
= 0 ; i
< count
&& ! result
; ++i
)
84 if (strcmp (id
, pods
[i
]) == 0)
93 * Perl subroutine declaration may look like one of the following:
98 * sub abc (proto) :attr;
100 * Note that there may be more than one attribute. Attributes may
101 * have things in parentheses (they look like arguments). Anything
102 * inside of those parentheses goes. Prototypes may contain semi-colons.
103 * The matching end when we encounter (outside of any parentheses) either
104 * a semi-colon (that'd be a declaration) or an left curly brace
107 * This is pretty complicated parsing (plus we all know that only perl can
108 * parse Perl), so we are only promising best effort here.
110 * If we can't determine what this is (due to a file ending, for example),
111 * we will return false.
113 static bool isSubroutineDeclaration (const unsigned char *cp
)
125 else if (true == attr
)
126 return false; /* Invalid attribute name */
149 if (isIdentifier1(*cp
)) {
151 while (isIdentifier (*cp
))
154 goto SUB_DECL_SWITCH
; /* Instead of --cp; */
158 } else if (nparens
) {
165 } while (NULL
!= (cp
= readLineFromInputFile ()));
170 /* Algorithm adapted from from GNU etags.
171 * Perl support by Bart Robinson <lomew@cs.utah.edu>
172 * Perl sub names: look for /^ [ \t\n]sub [ \t\n]+ [^ \t\n{ (]+/
174 static void findPerlTags (void)
176 vString
*name
= vStringNew ();
177 vString
*package
= NULL
;
178 bool skipPodDoc
= false;
179 const unsigned char *line
;
181 while ((line
= readLineFromInputFile ()) != NULL
)
183 bool spaceRequired
= false;
184 bool qualified
= false;
185 const unsigned char *cp
= line
;
186 perlKind kind
= K_NONE
;
191 if (strncmp ((const char*) line
, "=cut", (size_t) 4) == 0)
195 else if (line
[0] == '=')
197 skipPodDoc
= isPodWord ((const char*)line
+ 1);
200 else if (strcmp ((const char*) line
, "__DATA__") == 0)
202 else if (strcmp ((const char*) line
, "__END__") == 0)
204 else if (line
[0] == '#')
207 while (isspace (*cp
))
210 if (strncmp((const char*) cp
, "sub", (size_t) 3) == 0)
212 TRACE("this looks like a sub\n");
215 spaceRequired
= true;
218 else if (strncmp((const char*) cp
, "use", (size_t) 3) == 0)
223 while (*cp
&& isspace (*cp
))
225 if (strncmp((const char*) cp
, "constant", (size_t) 8) != 0)
229 spaceRequired
= true;
232 else if (strncmp((const char*) cp
, "package", (size_t) 7) == 0)
234 /* This will point to space after 'package' so that a tag
236 const unsigned char *space
= cp
+= 7;
239 package
= vStringNew ();
241 vStringClear (package
);
242 while (isspace (*cp
))
244 while ((int) *cp
!= ';' && !isspace ((int) *cp
))
246 vStringPut (package
, (int) *cp
);
249 vStringCatS (package
, "::");
251 cp
= space
; /* Rewind */
253 spaceRequired
= true;
256 else if (strncmp((const char*) cp
, "format", (size_t) 6) == 0)
260 spaceRequired
= true;
265 if (isIdentifier1 (*cp
))
267 const unsigned char *p
= cp
;
268 while (isIdentifier (*p
))
272 if ((int) *p
== ':' && (int) *(p
+ 1) != ':')
278 TRACE("cp0: %s\n", (const char *) cp
);
279 if (spaceRequired
&& *cp
&& !isspace (*cp
))
282 TRACE("cp1: %s\n", (const char *) cp
);
283 while (isspace (*cp
))
286 while (!*cp
|| '#' == *cp
) { /* Gobble up empty lines
288 cp
= readLineFromInputFile ();
291 while (isspace (*cp
))
295 while (isIdentifier (*cp
) || (K_PACKAGE
== kind
&& ':' == *cp
))
297 vStringPut (name
, (int) *cp
);
301 if (K_FORMAT
== kind
&&
302 vStringLength (name
) == 0 && /* cp did not advance */
305 /* format's name is optional. If it's omitted, 'STDOUT'
307 vStringCatS (name
, "STDOUT");
310 TRACE("name: %s\n", name
->buffer
);
312 if (0 == vStringLength(name
)) {
317 if (K_SUBROUTINE
== kind
)
320 * isSubroutineDeclaration() may consume several lines. So
321 * we record line positions.
323 initTagEntry(&e
, vStringValue(name
), kind
);
325 if (true == isSubroutineDeclaration(cp
)) {
326 if (true == PerlKinds
[K_SUBROUTINE_DECLARATION
].enabled
) {
327 kind
= K_SUBROUTINE_DECLARATION
;
337 if (isXtagEnabled(XTAG_QUALIFIED_TAGS
) && 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
, kind
);
350 if (isXtagEnabled(XTAG_QUALIFIED_TAGS
) && qualified
&&
352 package
!= NULL
&& vStringLength (package
) > 0)
354 vString
*const qualifiedName
= vStringNew ();
355 vStringCopy (qualifiedName
, package
);
356 vStringCat (qualifiedName
, name
);
357 makeSimpleTag (qualifiedName
, 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
->kindTable
= PerlKinds
;
376 def
->kindCount
= ARRAY_SIZE (PerlKinds
);
377 def
->extensions
= extensions
;
378 def
->parser
= findPerlTags
;