git.oblomov.eu Git - ohcount/blob - src/parsers/perl.rl

   1 // perl.rl written by Mitchell Foral. mitchell<att>caladbolg<dott>net
   2
   3 /************************* Required for every parser *************************/
   4 #ifndef OHCOUNT_PERL_PARSER_H
   5 #define OHCOUNT_PERL_PARSER_H
   6
   7 #include "../parser_macros.h"
   8
   9 // the name of the language
  10 const char *PERL_LANG = LANG_PERL;
  11
  12 // the languages entities
  13 const char *perl_entities[] = {
  14   "space", "comment", "string", "any"
  15 };
  16
  17 // constants associated with the entities
  18 enum {
  19   PERL_SPACE = 0, PERL_COMMENT, PERL_STRING, PERL_ANY
  20 };
  21
  22 /*****************************************************************************/
  23
  24 %%{
  25   machine perl;
  26   write data;
  27   include common "common.rl";
  28
  29   # Line counting machine
  30
  31   action perl_ccallback {
  32     switch(entity) {
  33     case PERL_SPACE:
  34       ls
  35       break;
  36     case PERL_ANY:
  37       code
  38       break;
  39     case INTERNAL_NL:
  40       std_internal_newline(PERL_LANG)
  41       break;
  42     case NEWLINE:
  43       std_newline(PERL_LANG)
  44     }
  45   }
  46
  47   perl_line_comment = '#' @comment nonnewline*;
  48   perl_block_comment =
  49     '=' when starts_line @enqueue @comment nonnewline+ (
  50       '=' when starts_line 'cut' @commit @comment @{ fgoto perl_line; }
  51       |
  52       newline %{ entity = INTERNAL_NL; } %perl_ccallback
  53       |
  54       ws
  55       |
  56       ^space @comment
  57     )* %/commit;
  58   perl_comment = perl_line_comment | perl_block_comment;
  59
  60   perl_sq_str =
  61     '\'' @enqueue @code (
  62       newline %{ entity = INTERNAL_NL; } %perl_ccallback
  63       |
  64       ws
  65       |
  66       [^\r\n\f\t '\\] @code
  67       |
  68       '\\' nonnewline @code
  69     )* '\'' @commit @code;
  70   perl_dq_str =
  71     '"' @enqueue @code (
  72       newline %{ entity = INTERNAL_NL; } %perl_ccallback
  73       |
  74       ws
  75       |
  76       [^\r\n\f\t "\\] @code
  77       |
  78       '\\' nonnewline @code
  79     )* '"' @commit @code;
  80   perl_cmd_str =
  81     '`' @enqueue @code (
  82       newline %{ entity = INTERNAL_NL; } %perl_ccallback
  83       |
  84       ws
  85       |
  86       [^\r\n\f\t `\\] @code
  87       |
  88       '\\' nonnewline @code
  89     )* '`' @commit @code;
  90   perl_regex = '/' ([^\r\n\f/\\] | '\\' nonnewline)* '/' @code;
  91   # TODO: heredoc detection
  92   # This is impossible with current Ragel. We need to extract what the end
  93   # delimiter should be from the heredoc and search up to it on a new line.
  94   # perl_heredoc =
  95   perl_string = perl_sq_str | perl_dq_str | perl_cmd_str | perl_regex;
  96
  97   perl_line := |*
  98     spaces         ${ entity = PERL_SPACE; } => perl_ccallback;
  99     perl_comment;
 100     perl_string;
 101     newline        ${ entity = NEWLINE;    } => perl_ccallback;
 102     '=' when !starts_line;
 103     ^(space | '=') ${ entity = PERL_ANY;   } => perl_ccallback;
 104   *|;
 105
 106   # Entity machine
 107
 108   action perl_ecallback {
 109     callback(PERL_LANG, perl_entities[entity], cint(ts), cint(te), userdata);
 110   }
 111
 112   perl_line_comment_entity = '#' nonnewline*;
 113   perl_block_comment_entity =
 114     ('=' when starts_line) alpha+ any* :>> (('=' when starts_line) 'cut');
 115   perl_comment_entity = perl_line_comment_entity | perl_block_comment_entity;
 116
 117   perl_entity := |*
 118     space+              ${ entity = PERL_SPACE;   } => perl_ecallback;
 119     perl_comment_entity ${ entity = PERL_COMMENT; } => perl_ecallback;
 120     # TODO:
 121     ^space;
 122   *|;
 123 }%%
 124
 125 /************************* Required for every parser *************************/
 126
 127 /* Parses a string buffer with Perl code.
 128  *
 129  * @param *buffer The string to parse.
 130  * @param length The length of the string to parse.
 131  * @param count Integer flag specifying whether or not to count lines. If yes,
 132  *   uses the Ragel machine optimized for counting. Otherwise uses the Ragel
 133  *   machine optimized for returning entity positions.
 134  * @param *callback Callback function. If count is set, callback is called for
 135  *   every line of code, comment, or blank with 'lcode', 'lcomment', and
 136  *   'lblank' respectively. Otherwise callback is called for each entity found.
 137  */
 138 void parse_perl(char *buffer, int length, int count,
 139                 void (*callback) (const char *lang, const char *entity, int s,
 140                                   int e, void *udata),
 141                 void *userdata
 142   ) {
 143   init
 144
 145   %% write init;
 146   cs = (count) ? perl_en_perl_line : perl_en_perl_entity;
 147   %% write exec;
 148
 149   // if no newline at EOF; callback contents of last line
 150   if (count) { process_last_line(PERL_LANG) }
 151 }
 152
 153 #endif
 154
 155 /*****************************************************************************/