Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
Test program:
use My::Exception::Class ( 'My::Exception::BadInput' => { isa => 'My::Exception', }, ); package ABC; use constant PACKAGE_CONSTANT => 'abc'; sub xyz { print "hello\n"; } package main; use ABC; ABC::xyz(); if (1) { goto XYZ; } XYZ: print "OK"; My::Exception::BadInput->throw(message => ABC::PACKAGE_CONSTANT);

The patch:

Index: options.c =================================================================== RCS file: /cvsroot/ThirdParty/ctags/options.c,v retrieving revision 1.1.1.2 retrieving revision 1.3 diff -u -r1.1.1.2 -r1.3 --- options.c 31 Mar 2005 22:12:49 -0000 1.1.1.2 +++ options.c 31 Mar 2005 22:17:59 -0000 1.3 @@ -1433,6 +1433,29 @@ return found; } +static boolean processLangSpecificOption ( + const char *const option, const char *const parameter) +{ + boolean handled = FALSE; + + if (option == strstr(option, "language-specific:")) { + const char *language = option + sizeof("language-specific:") +- 1; + parserSpecificOption parser = getLanguageSpecificOptionParser +(language); + + if (!parser) + error(FATAL, "No option parser could be found for languag +e '%s'", + language); + + if (0 != parser(parameter)) + error(FATAL, "Apparently, %s option parser does not like +" + "this argument: '%s'", language, parameter); + + handled = TRUE; + } + + return handled; +} + static boolean getBooleanOption ( const char *const option, const char *const parameter) { @@ -1488,6 +1511,8 @@ ; else if (processRegexOption (option, parameter)) ; + else if (processLangSpecificOption (option, parameter)) + ; #ifndef RECURSE_SUPPORTED else if (strcmp (option, "recurse") == 0) error (WARNING, "%s option not supported on this host", option); Index: parse.c =================================================================== RCS file: /cvsroot/ThirdParty/ctags/parse.c,v retrieving revision 1.1.1.2 retrieving revision 1.3 diff -u -r1.1.1.2 -r1.3 --- parse.c 31 Mar 2005 22:12:49 -0000 1.1.1.2 +++ parse.c 31 Mar 2005 22:17:59 -0000 1.3 @@ -64,6 +64,7 @@ { parserDefinition* result = xCalloc (1, parserDefinition); result->name = eStrdup (name); + result->parser_opts = NULL; /* Backward-compatible */ return result; } @@ -506,6 +507,21 @@ printKinds (language, FALSE); } +extern parserSpecificOption getLanguageSpecificOptionParser ( + const char *language) +{ + int i; + + if (!language) + return NULL; + + for (i = 0; i < LanguageCount; ++i) + if (0 == strcasecmp(language, LanguageTable[i]->name)) + return LanguageTable[i]->parser_opts; + + return NULL; +} + static void printMaps (const langType language) { const parserDefinition* lang; Index: parse.h =================================================================== RCS file: /cvsroot/ThirdParty/ctags/parse.h,v retrieving revision 1.1.1.1 retrieving revision 1.2 diff -u -r1.1.1.1 -r1.2 --- parse.h 24 Jan 2005 17:51:42 -0000 1.1.1.1 +++ parse.h 10 Feb 2005 23:34:12 -0000 1.2 @@ -35,6 +35,8 @@ typedef void (*simpleParser) (void); typedef boolean (*rescanParser) (const unsigned int passCount); typedef void (*parserInitialize) (langType language); +/* Return 0 on success, -1 on failure */ +typedef int (*parserSpecificOption) (const char *option); typedef struct sKindOption { boolean enabled; /* are tags for kind enabled? */ @@ -54,6 +56,7 @@ simpleParser parser; /* simple parser (common case) */ rescanParser parser2; /* rescanning parser (unusual case) +*/ boolean regex; /* is this a regex parser? */ + parserSpecificOption parser_opts; /* parser-specific options pa +rser */ /* used internally */ unsigned int id; /* id assigned to language */ @@ -122,6 +125,7 @@ extern void printRegexKinds (const langType language, boolean indent) +; extern void freeRegexResources (void); extern void checkRegex (void); +extern parserSpecificOption getLanguageSpecificOptionParser (const ch +ar *language); #endif /* _PARSE_H */ Index: perl.c =================================================================== RCS file: /cvsroot/ThirdParty/ctags/perl.c,v retrieving revision 1.1.1.2 retrieving revision 1.7 diff -u -r1.1.1.2 -r1.7 --- perl.c 31 Mar 2005 22:12:49 -0000 1.1.1.2 +++ perl.c 11 Feb 2005 00:13:01 -0000 1.7 @@ -1,5 +1,5 @@ /* -* $Id: perl.c,v 1.13 2004/03/13 21:51:07 darren Exp $ +* $Id: perl.c,v 1.8 2003/04/01 04:55:27 darren Exp $ * * Copyright (c) 2000-2003, Darren Hiebert * @@ -15,69 +15,189 @@ */ #include "general.h" /* must always come first */ +#include <ctype.h> #include <string.h> -#include "options.h" #include "read.h" -#include "routines.h" #include "vstring.h" /* * DATA DEFINITIONS */ typedef enum { - K_NONE = -1, + K_SUBROUTINE, + K_PACKAGE, K_CONSTANT, K_LABEL, - K_SUBROUTINE + K_EXCEPTION, } perlKind; static kindOption PerlKinds [] = { + { TRUE, 's', "subroutine", "subroutines" }, + { TRUE, 'p', "package", "packages" }, { TRUE, 'c', "constant", "constants" }, { TRUE, 'l', "label", "labels" }, - { TRUE, 's', "subroutine", "subroutines" } + { TRUE, 'e', "exception", "exceptions" }, }; -/* -* FUNCTION DEFINITIONS -*/ +static struct { + char str[1024]; + int set; +} package = { "", 0 }; + +struct exception_node { + const char *name; + struct exception_node *next; +}; + +typedef struct exception_node exception_node_t; + +static exception_node_t *exceptions = NULL; + +#define NOLABEL_STR "{(;=" +#define LABEL_STR ":" + -static boolean isIdentifier1 (int c) +#define SKIP_WHITESPACE(cp) \ + do { \ + while (*cp && isspace(*cp)) \ + ++cp; \ + } while (!*cp && NULL != (cp = fileReadLine())) + + +const unsigned char * +create_exception_class_tags (const unsigned char *cp) { - return (boolean) (isalpha (c) || c == '_'); + vString *name; + const unsigned char *s; + + do { + SKIP_WHITESPACE(cp); + if (!cp) + return NULL; + +START_EXC: + /* First, try to detect end of exception list */ + if (')' == *cp) { + SKIP_WHITESPACE(cp); + if (cp && ';' == *cp) + return cp + 1; + else + return cp; /* Should be NULL */ + } + + /* Second, find exception name */ + if ('\'' == *cp || '"' == *cp) + ++cp; + s = cp; + + while (*cp && (isalnum(*cp) || ':' == *cp)) + ++cp; + + name = vStringNew(); + vStringNCatS(name, s, cp - s); + makeSimpleTag(name, PerlKinds, K_EXCEPTION); + vStringDelete(name); + + /* Third, skip exception value */ + do { + while (*cp && '}' != *cp) + ++cp; + if ('}' == *cp) { + ++cp; + SKIP_WHITESPACE(cp); + if (!cp) + return NULL; + if (',' == *cp) { + ++cp; + break; + } + else if (')' == *cp) + goto START_EXC; + } else if ('\0' == *cp) { + cp = fileReadLine(); + } + } while (cp); + } while (1); + + return cp; /* Should never reach here... */ } -static boolean isIdentifier (int c) + +static int +push_exception (const char *name) { - return (boolean) (isalnum (c) || c == '_'); + exception_node_t *node, *ptr; + + if (!name) + return -1; + + node = malloc(sizeof(exception_node_t)); + node->name = name; + node->next = NULL; + + if (exceptions) { + for (ptr = exceptions; ptr->next; ptr = ptr->next) + ; + ptr->next = node; + } else { + exceptions = node; + } + + return 0; } -static boolean isPodWord (const char *word) + +static int +match_exception (const unsigned char *cp) { - boolean result = FALSE; - if (isalpha (*word)) - { - const char *const pods [] = { - "head1", "head2", "head3", "head4", "over", "item", "back", - "pod", "begin", "end", "for" - }; - const size_t count = sizeof (pods) / sizeof (pods [0]); - const char *white = strpbrk (word, " \t"); - const size_t len = (white!=NULL) ? (size_t)(white-word) : strlen +(word); - char *const id = (char*) eMalloc (len + 1); - size_t i; - strncpy (id, word, len); - id [len] = '\0'; - for (i = 0 ; i < count && ! result ; ++i) - { - if (strcmp (id, pods [i]) == 0) - result = TRUE; - } - eFree (id); + char *name; + int len = 0; + exception_node_t *node; + + for (name = (char *) cp; *name; ++name) { + if (!(isalnum(*name) || ':' == *name)) + break; + ++len; } - return result; + + if (!len) + return 0; + + name = malloc(len + 1); + strncpy(name, cp, len); + name[len] = '\0'; + + for (node = exceptions; node; node = node->next) { + if (0 == strcmp(node->name, name)) { + free(name); + return len; + } + } + + free(name); + return 0; } + +static int +parsePerlOption (const char *option) +{ + if (!option) + return -1; + + if (option == strstr(option, "exception=")) { + const char *name = option + sizeof("exception=") - 1; + if (push_exception(name)) + return -1; + } else { + return -1; + } + + return 0; +} + + /* Algorithm adapted from from GNU etags. * Perl support by Bart Robinson <lomew@cs.utah.edu> * Perl sub names: look for /^ [ \t\n]sub [ \t\n]+ [^ \t\n{ (]+/ @@ -85,16 +205,16 @@ static void findPerlTags (void) { vString *name = vStringNew (); - vString *package = NULL; boolean skipPodDoc = FALSE; const unsigned char *line; + perlKind kind; + + package.set = 0; while ((line = fileReadLine ()) != NULL) { - boolean spaceRequired = FALSE; - boolean qualified = FALSE; - const unsigned char *cp = line; - perlKind kind = K_NONE; + const unsigned char *cp = line, *aux; + int sub = 0, use = 0, lbl = 0; /* This will save up strcmps +later */ if (skipPodDoc) { @@ -104,7 +224,8 @@ } else if (line [0] == '=') { - skipPodDoc = isPodWord ((const char*)line + 1); + skipPodDoc = (boolean) (strncmp ( + (const char*) line + 1, "cut", (size_t) 3) != 0); continue; } else if (strcmp ((const char*) line, "__DATA__") == 0) @@ -117,86 +238,102 @@ while (isspace (*cp)) cp++; - if (strncmp((const char*) cp, "sub", (size_t) 3) == 0) + /* Try to find a label here */ + for (aux = cp; *aux && isalnum(*aux); ++aux) + ; + if (aux > cp) { + while (isspace(*aux)) + ++aux; + if (':' == *aux && (aux[1] ? ':' != aux[1] : 1)) + lbl = 1; + } + + if (lbl + || + (strncmp((const char*) cp, "sub", (size_t) 3) == 0 && (su +b = 1)) || + (strncmp((const char*) cp, "use", (size_t) 3) == 0 && (us +e = 1)) || + strncmp((const char*) cp, "package", (size_t) 7) == 0) { - cp += 3; - kind = K_SUBROUTINE; - spaceRequired = TRUE; - qualified = TRUE; - } - else if (strncmp((const char*) cp, "use", (size_t) 3) == 0) - { - cp += 3; - if (!isspace(*cp)) - continue; - while (*cp && isspace (*cp)) - ++cp; - if (strncmp((const char*) cp, "constant", (size_t) 8) != 0) - continue; - cp += 8; - kind = K_CONSTANT; - spaceRequired = TRUE; - qualified = TRUE; - } - else if (strncmp((const char*) cp, "package", (size_t) 7) == 0) - { - cp += 7; - if (package == NULL) - package = vStringNew (); - else - vStringClear (package); - while (isspace (*cp)) - cp++; - while ((int) *cp != ';' && !isspace ((int) *cp)) + if (sub) { - vStringPut (package, (int) *cp); - cp++; - } - vStringCatS (package, "::"); - } - else - { - if (isIdentifier1 (*cp)) - { - const unsigned char *p = cp; - while (isIdentifier (*p)) - ++p; - if ((int) *p == ':') - kind = K_LABEL; + cp += 3; + kind = K_SUBROUTINE; + } else if (use) { + size_t exc_len; + + cp += 3; + if (!isspace(*cp)) + continue; + while (*cp && isspace(*cp)) + ++cp; + if (!strncmp((const char*) cp, "constant", (size_t) 8 +)) { + cp += 8; + kind = K_CONSTANT; + } else if ((exc_len = match_exception(cp)) > 0) { + cp += exc_len; + SKIP_WHITESPACE(cp); + if (!cp) + break; /* EOF */ + if ('(' != *cp) + continue; + + cp = create_exception_class_tags(cp + 1); + continue; + } else { + continue; + } + } else if (lbl) { + kind = K_LABEL; + } else { + cp += 7; + kind = K_PACKAGE; } - } - if (kind != K_NONE) - { - if (spaceRequired && !isspace (*cp)) + + /* This check is only performed if not a label */ + if (!(lbl || isspace(*cp))) /* woops, not followed by a s +pace */ continue; while (isspace (*cp)) cp++; - while (isIdentifier (*cp)) + while (! isspace ((int) *cp) && *cp != '\0' && + strchr ((lbl ? LABEL_STR : NOLABEL_STR), (int) *cp +) == NULL) { vStringPut (name, (int) *cp); cp++; } vStringTerminate (name); - if (vStringLength (name) > 0) - { + + if (vStringLength (name) > 0) { makeSimpleTag (name, PerlKinds, kind); - if (Option.include.qualifiedTags && qualified && - package != NULL && vStringLength (package) > 0) - { - vString *const qualifiedName = vStringNew (); - vStringCopy (qualifiedName, package); - vStringCat (qualifiedName, name); - makeSimpleTag (qualifiedName, PerlKinds, kind); - vStringDelete (qualifiedName); - } - } + if (K_PACKAGE == kind && + vStringLength(name) < sizeof(package.str)) + { + strcpy(package.str, vStringValue(name)); + package.set = 1; + } else if ((K_SUBROUTINE == kind || K_CONSTANT == kin +d) + && package.set) + { + /* Make full subroutine tag, e.g. Net::NAD::new( +) */ + vString *fname = vStringNew(); + vStringCatS(fname, package.str); + vStringCatS(fname, "::"); + vStringCatS(fname, vStringValue(name)); + makeSimpleTag(fname, PerlKinds, kind); + vStringDelete(fname); + + /* Make method tag, e.g. Net::NAD->new() */ + fname = vStringNew(); + vStringCatS(fname, package.str); + vStringCatS(fname, "->"); + vStringCatS(fname, vStringValue(name)); + makeSimpleTag(fname, PerlKinds, kind); + vStringDelete(fname); + } + } + vStringClear (name); } } vStringDelete (name); - if (package != NULL) - vStringDelete (package); } extern parserDefinition* PerlParser (void) @@ -207,6 +344,7 @@ def->kindCount = KIND_COUNT (PerlKinds); def->extensions = extensions; def->parser = findPerlTags; + def->parser_opts= parsePerlOption; return def; }

In reply to ctags: better Perl support by dmitri

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others taking refuge in the Monastery: (4)
As of 2024-03-19 08:30 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found