1 package Parsers::Lexer;
   2 #
   3 # File: Lexer.pm
   4 # Author: Manish Sud <msud@san.rr.com>
   5 #
   6 # Copyright (C) 2024 Manish Sud. All rights reserved.
   7 #
   8 # This file is part of MayaChemTools.
   9 #
  10 # MayaChemTools is free software; you can redistribute it and/or modify it under
  11 # the terms of the GNU Lesser General Public License as published by the Free
  12 # Software Foundation; either version 3 of the License, or (at your option) any
  13 # later version.
  14 #
  15 # MayaChemTools is distributed in the hope that it will be useful, but without
  16 # any warranty; without even the implied warranty of merchantability of fitness
  17 # for a particular purpose.  See the GNU Lesser General Public License for more
  18 # details.
  19 #
  20 # You should have received a copy of the GNU Lesser General Public License
  21 # along with MayaChemTools; if not, see <http://www.gnu.org/licenses/> or
  22 # write to the Free Software Foundation Inc., 59 Temple Place, Suite 330,
  23 # Boston, MA, 02111-1307, USA.
  24 #
  25 
  26 use strict;
  27 use Carp;
  28 use Exporter;
  29 use Scalar::Util ();
  30 
  31 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  32 
  33 @ISA = qw(Exporter);
  34 @EXPORT = qw();
  35 @EXPORT_OK = qw();
  36 
  37 %EXPORT_TAGS = (all  => [@EXPORT, @EXPORT_OK]);
  38 
  39 # Setup class variables...
  40 my($ClassName);
  41 _InitializeClass();
  42 
  43 # Overload Perl functions...
  44 use overload '""' => 'StringifyLexer';
  45 
  46 # Class constructor...
  47 sub new {
  48   my($Class, $Input, @TokensSpec) = @_;
  49 
  50   # Initialize object...
  51   my $This = {};
  52   bless $This, ref($Class) || $Class;
  53   $This->_InitializeLexer();
  54 
  55   $This->_ValidateParametersAndGenerateLexer($Input, @TokensSpec);
  56 
  57   return $This;
  58 }
  59 
  60 
  61 # Initialize class ...
  62 sub _InitializeClass {
  63   #Class name...
  64   $ClassName = __PACKAGE__;
  65 }
  66 
  67 # Initialize object data...
  68 #
  69 sub _InitializeLexer {
  70   my($This) = @_;
  71 
  72   # Input parameter used by lexer to retrieve text to be lexed. Supported parameter types:
  73   #   . Reference to input iterator function
  74   #   . Reference to an open file handle
  75   #   . Text string
  76   #
  77   $This->{Input} = undef;
  78 
  79   # Type of input paramater determined using Perl ref function:
  80   #   . InputIterator - ref returns CODE
  81   #   . FileStream - ref return GLOB and fileno is valid
  82   #   . String - ref return an empty string
  83   #
  84   $This->{InputType} = '';
  85 
  86   # Tokens specifications supplied by the caller. It's an array containing references
  87   # to arrays with each containing TokenLabel and TokenMatchRegex pair along with
  88   # an option reference to code to be executed after a matched.
  89   #
  90   # For example:
  91   #
  92   # @LexerTokensSpec = (
  93   #                        [ 'LETTER', qr/[a-zA-Z]/ ],
  94   #                        [ 'NUMBER', qr/\d+/ ],
  95   #                        [ 'SPACE', qr/[ ]*/, sub { my($This, $TokenLabel, $MatchedText) = @_; return ''; } ],
  96   #                        [ 'NEWLINE', qr/(?:\r\n|\r|\n)/, sub { my($This, $TokenLabel, $MatchedText) = @_;  return "\n"; } ],
  97   #                        [ 'CHAR', qr/[\.]/ ],
  98   #                       );
  99   #
 100   @{$This->{TokensSpec}} = ();
 101 
 102   # Refernce to chained lexer...
 103   $This->{ChainedLexer} = undef;
 104 
 105   return $This;
 106 }
 107 
 108 # Validate input parameters and generate a chained lexer...
 109 #
 110 sub _ValidateParametersAndGenerateLexer {
 111   my($This, $Input, @TokensSpec) = @_;
 112 
 113   #
 114   # Validate input to be lexed...
 115   if (!defined $Input) {
 116     croak "Error: ${ClassName}->new: Object can't be instantiated: Input is not defined. Supported values: a reference to input iterator function, a reference to an open file handle or a text string...";
 117   }
 118   $This->{Input} = $Input;
 119 
 120   # Check input parameter type...
 121   my($InputType);
 122 
 123   $InputType = ref $Input;
 124   if ($InputType =~ /CODE/i) {
 125     # Input iterator...
 126     $This->{InputType} = "InputIterator";
 127   }
 128   elsif ($InputType =~ /GLOB/i && defined fileno $Input) {
 129     # Input stream...
 130     $This->{InputType} = "FileStream";
 131   }
 132   elsif ($InputType) {
 133     # Perl ref function returns nonempty string for all other references...
 134     croak "Error: ${ClassName}->new: Object can't be instantiated: Invalid input parameter type specified. Supported parameter types: a reference to input iterator function, a reference to an open file handle or a text string...";
 135   }
 136   else {
 137     # Input string...
 138     $This->{InputType} = "String";
 139   }
 140 
 141   # Check tokens specifications...
 142   if (!@TokensSpec) {
 143     croak "Error: ${ClassName}->new: TokensSpec is not defined or the array doesn't contain any values. Supported values: a reference to an array containg token label, regular expression to match and an option reference to function to modify matched values...";
 144   }
 145   @{$This->{TokensSpec}} = @TokensSpec;
 146 
 147   $This->_GenerateLexer($Input, @TokensSpec);
 148 
 149   return $This;
 150 }
 151 
 152 # Generate a lexer using reference to an input iterator function, an open file
 153 # handle or an input string passed as first parameter by the caller along
 154 # with token specifications as second paramater...
 155 #
 156 sub _GenerateLexer {
 157   my($This, $Input, @TokensSpec) = @_;
 158 
 159   if ($This->{InputType} =~ /^InputIterator$/i) {
 160     $This->_GenerateInputIteratorLexer($Input, @TokensSpec);
 161   }
 162   elsif ($This->{InputType} =~ /^FileStream$/i) {
 163     $This->_GenerateInputFileStreamLexer($Input, @TokensSpec);
 164   }
 165   elsif ($This->{InputType} =~ /^String$/i) {
 166     $This->_GenerateInputStringLexer($Input, @TokensSpec);
 167   }
 168   else {
 169     croak "Error: ${ClassName}->new: Object can't be instantiated: Invalid input parameter type specified. Supported parameter types: a reference to input iterator function, a reference to an open file handle or a text string...";
 170   }
 171 
 172   return $This;
 173 }
 174 
 175 # Generate a lexer using specifed input iterator...
 176 #
 177 sub _GenerateInputIteratorLexer {
 178   my($This, $InputIteratorRef, @TokensSpec) = @_;
 179 
 180   $This->_GenerateChainedLexer($InputIteratorRef, @TokensSpec);
 181 
 182   return $This;
 183 }
 184 
 185 # Generate a lexer using specifed input file stream reference...
 186 #
 187 sub _GenerateInputFileStreamLexer {
 188   my($This, $FileHandleRef, @TokensSpec) = @_;
 189 
 190   # Iterator is a annoymous function reference and Perl keeps $FileHandleRef
 191   # in scope during its execution.
 192 
 193   $This->_GenerateChainedLexer( sub { return <$FileHandleRef>; }, @TokensSpec);
 194 
 195   return $This;
 196 }
 197 
 198 # Generate a lexer using specifed input string...
 199 #
 200 sub _GenerateInputStringLexer {
 201   my($This, $Text, @TokensSpec) = @_;
 202   my(@InputText) = ($Text);
 203 
 204   # Iterator is a annoymous function reference and Perl keeps @InputText
 205   # in scope during its execution.
 206 
 207   $This->_GenerateChainedLexer( sub { return shift @InputText; }, @TokensSpec);
 208 
 209   return $This;
 210 }
 211 
 212 # Get next available token label and value pair as an array reference or unrecognized
 213 # text from input stream by either removing it from the input or simply peeking ahead...
 214 #
 215 # Supported mode values: Peek, Next. Default: Next
 216 #
 217 sub Lex {
 218   my($This, $Mode) = @_;
 219 
 220   return $This->{ChainedLexer}->($Mode)
 221 }
 222 
 223 # Get next available token label and value pair as an array reference or unrecognized
 224 # text from input stream by either removing it from the input stream...
 225 #
 226 sub Next {
 227   my($This) = @_;
 228 
 229   return $This->Lex();
 230 }
 231 
 232 # Get next available token label and value pair as an array reference or unrecognized
 233 # text from input stream by simply peeking ahead and without removing it from the input
 234 # stream..
 235 #
 236 sub Peek {
 237   my($This) = @_;
 238 
 239   return $This->Lex('Peek')
 240 }
 241 
 242 # Get a reference to lexer method to be used by the caller...
 243 #
 244 sub GetLex {
 245   my($This) = @_;
 246 
 247   return sub { $This->Lex(); };
 248 }
 249 
 250 # The chained lexer generation is implemented based on examples in Higher-order Perl
 251 # [ Ref 126 ] book.
 252 #
 253 # Generate a lexer using specified input iterator and chaining it with other lexers generated
 254 # for all token specifications. The lexer generated for first token specification uses input
 255 # iterator to retrieve any available input text; the subsequent chained lexeres for rest
 256 # of the tokens use lexers generated for previous token specifications to get next input
 257 # which might be unmatched input text or a reference to an array containing token and
 258 # matched text pair.
 259 #
 260 sub _GenerateChainedLexer {
 261   my($This, $InputIteratorRef, @TokensSpec) = @_;
 262   my($TokenSpecRef, $ChainedLexer);
 263 
 264   $ChainedLexer = undef;
 265   for $TokenSpecRef (@TokensSpec) {
 266     $ChainedLexer = defined $ChainedLexer ? $This->_GenerateLexerForToken($ChainedLexer, @{$TokenSpecRef}) : $This->_GenerateLexerForToken($InputIteratorRef, @{$TokenSpecRef});
 267   }
 268 
 269   $This->{ChainedLexer} = $ChainedLexer;
 270 
 271   return $This;
 272 }
 273 
 274 
 275 # Generate a lexer using specifed token specification using specified input or
 276 # input retrieved using another token lexer. The lexer retrieving input from the
 277 # specified input stream is at the bottom of the chain.
 278 #
 279 sub _GenerateLexerForToken {
 280   my($This, $InputIteratorOrLexer, $TokenLabel, $RegexPattern, $TokenMatchActionRef) = @_;
 281   my($TokenMatchAndSplitRef, $InputBuffer, @ProcessedTokens);
 282 
 283   # Input buffer for a specific lexer in chained lexers containing unprocessed
 284   # text for token specifications retrieved from a downstrean lexer or intial
 285   # input...
 286   #
 287   $InputBuffer = "";
 288 
 289   # @ProcessedTokens contains either references to an array containing token label
 290   # and matched text or any unmatched input text string...
 291   #
 292   @ProcessedTokens = ();
 293 
 294   # Setup a default annoymous function reference to generate an array reference
 295   # containing $Token and text matched to $RegexPattern.
 296   #
 297   $TokenMatchActionRef = defined $TokenMatchActionRef ? $TokenMatchActionRef : sub { my($This, $Label, $MatchedText) = @_; return [$Label, $MatchedText]  };
 298 
 299   # Setup an annoymous function to match and split input text using $RegexPattern for
 300   # a specific token during its lexer invocation in chained lexers.
 301   #
 302   # The usage of parenthesis around $RegexPattern during split allows capturing of matched
 303   # text, which is subsequently processed to retrieve matched $Token values. The split function
 304   # inserts a "" separator in the returned array as first entry whenever $InputText starts with
 305   # $RegexPattern. $InputText is returned as the only element for no match.
 306   #
 307   $TokenMatchAndSplitRef = sub { my($InputText) = @_; return split /($RegexPattern)/, $InputText; };
 308 
 309   # Setup a lexer for $TokenLabel as an annoymous function and return its reference to caller
 310   # which in turns chains the lexers for all $Tokens before returning a reference to a lexer
 311   # at top of the lexer chain.
 312   #
 313   # Perl maintains scope of all variables defined with in the scope of the current function
 314   # during invocation of annoymous function even after the return call.
 315   #
 316   return sub {
 317     my($Mode) = @_;
 318 
 319     # Currenly supported value for mode: Peek, Next
 320     #
 321     $Mode = defined $Mode ? $Mode : 'Next';
 322 
 323     while (@ProcessedTokens == 0 && defined $InputBuffer ) {
 324       # Get any new input....
 325       my $NewInput = $InputIteratorOrLexer->();
 326 
 327       if (ref $NewInput) {
 328         # Input is an array reference containing matched token and text returned by
 329         # a chained lexer downstream lexer...
 330         #
 331         # Match $RegexPattern in available buffer text to retieve any matched text
 332         # for current $Token. $Separator might be "": $RegexPattern is at start of
 333         # of $InputBuffer
 334         #
 335         # Process input buffer containing text to be matched for the current lexer
 336         # which didn't get processed earlier during @NewTokens > 2  while loop:
 337         # no match for current lexer or more input available. It maintains order
 338         # of token matching in input stream.
 339         #
 340         my($Separator, $MatchedTokenRefOrText);
 341 
 342         ($Separator, $MatchedTokenRefOrText) = $TokenMatchAndSplitRef->($InputBuffer);
 343         if (defined $MatchedTokenRefOrText) {
 344           $MatchedTokenRefOrText = $TokenMatchActionRef->($This, $TokenLabel, $MatchedTokenRefOrText);
 345         }
 346 
 347         # Collect valid token references or text...
 348         push @ProcessedTokens, grep { defined $_ && $_ ne "" } ($Separator, $MatchedTokenRefOrText, $NewInput);
 349 
 350         # Empty put buffer...
 351         $InputBuffer = "";
 352 
 353         # Get out of the loop as processed token refererences and/or text  are available...
 354         last;
 355       }
 356 
 357       # Process input retrieved from downstream lexer or input iterator which hasn't
 358       # been processed into tokens..
 359       if (defined $NewInput) {
 360         $InputBuffer .= $NewInput;
 361       }
 362 
 363       # Retrieve any matched tokens from available input for the current lexer...
 364       #
 365       my(@NewTokens) = $TokenMatchAndSplitRef->($InputBuffer);
 366 
 367       while ( @NewTokens > 2 || @NewTokens && !defined $NewInput) {
 368         # Scenario 1: Complete match
 369         #   @NewTokens > 2 : Availability of separator, matched token text, separator.
 370         #   The separator might correspond to token for a token for upstream lexer followed
 371         #   by matched token from current lexer. It ends up getting passed to upsrteam
 372         #   lexer for processing.
 373         #
 374         # Scenario 2: No more input available from iterator or downstream lexer
 375         #   @NewTokens <= 2 and no more input implies any left over text in buffer. And
 376         #   it ends up getting passed to upsrteam for processing.
 377         #
 378 
 379         # Take off any unprocessed input text that doesn't match off the buffer: It'll be
 380         # passed to upstream chained lexer for processing...
 381         #
 382         push @ProcessedTokens, shift @NewTokens;
 383 
 384         if (@NewTokens) {
 385           my $MatchedTokenText = shift @NewTokens;
 386           push @ProcessedTokens, $TokenMatchActionRef->($This, $TokenLabel, $MatchedTokenText);
 387         }
 388       }
 389 
 390       # Retrieve any leftover text from NewTokens and put it back into InputBuffer for
 391       # processing by current lexer. All token references have been taken out....
 392       #
 393       $InputBuffer = "";
 394       if (@NewTokens) {
 395         $InputBuffer = join "", @NewTokens;
 396       }
 397 
 398       if (!defined $NewInput) {
 399         # No more input from the downstream lexer...
 400         $InputBuffer = undef;
 401       }
 402 
 403       # Clean up any empty strings from ProcessedTokens containing token
 404       # references or text...
 405       @ProcessedTokens = grep { $_ ne "" } @ProcessedTokens;
 406 
 407     }
 408 
 409     # Return reference to an array containing token and matched text or just unmatched input text...
 410     my $TokenRefOrText = undef;
 411 
 412     if (@ProcessedTokens) {
 413       # Get first available reference either by just peeking or removing it from the list
 414       # of available tokens...
 415       $TokenRefOrText = ($Mode =~ /^Peek$/i) ?  $ProcessedTokens[0] : shift @ProcessedTokens;
 416     }
 417 
 418     return $TokenRefOrText;
 419   };
 420 }
 421 
 422 # Is it a lexer object?
 423 sub _IsLexer {
 424   my($Object) = @_;
 425 
 426   return (Scalar::Util::blessed($Object) && $Object->isa($ClassName)) ? 1 : 0;
 427 }
 428 
 429 # Return a string containing information about lexer...
 430 sub StringifyLexer {
 431   my($This) = @_;
 432   my($LexerString);
 433 
 434   $LexerString = "Lexer: PackageName: $ClassName; " . $This->_GetLexerInfoString();
 435 
 436   return $LexerString;
 437 }
 438 
 439 # Return a string containing information about lexer...
 440 sub _GetLexerInfoString {
 441   my($This) = @_;
 442   my($LexerInfoString, $TokensSpec, $TokenSpec, $TokenLabel, $TokenMatchRegex, $TokenMatchAction);
 443 
 444   $LexerInfoString = "InputType: $This->{InputType}";
 445 
 446   if ($This->{InputType} =~ /^String$/i) {
 447     $LexerInfoString .= "; InputString: $This->{Input}";
 448   }
 449 
 450   $TokensSpec = "TokensSpecifications: <None>";
 451   if (@{$This->{TokensSpec}}) {
 452     $TokensSpec = "TokensSpecifications: < [Label, MatchRegex, MatchAction]:";
 453     for $TokenSpec (@{$This->{TokensSpec}}) {
 454       ($TokenLabel, $TokenMatchRegex) = @{$TokenSpec};
 455       $TokenMatchAction = (@{$TokenSpec} == 3) ? "$TokenSpec->[2]" : "undefined";
 456       $TokensSpec .= " [$TokenLabel, $TokenMatchRegex, $TokenMatchAction]";
 457     }
 458     $TokensSpec .= " >";
 459   }
 460 
 461   $LexerInfoString .= "; $TokensSpec";
 462 
 463   return $LexerInfoString;
 464 }
 465