view release on metacpan or  search on metacpan

lib/PPR/X.pm  view on Meta::CPAN

  use overload q{""} => 'source', q{0+} => 'line', fallback => 1;

  sub new {
      my ($class, %obj) = @_;
      return bless \%obj, $class;
  }

  sub prefix { return shift->{prefix} }

  sub source { return shift->{source} }

  sub line   { my $self = shift;
               my $offset = $self->{line} // shift // 1;
               return $offset + $self->{prefix} =~ tr/\n//;
              }

  sub origin { my $self = shift;
               my $line = shift // 0;
               my $file = shift // "";
               return bless { %{$self}, line => $line, file => $file }, ref($self);
             }

  sub diagnostic { my $self = shift;
                   my $line = defined $self->{line}
                                    ? $self->{line} + $self->{prefix} =~ tr/\n//
                                    : 0;
                   my $file = $self->{file} // q{};
                   return q{} if eval "no strict;\n"
                                    . "#line $line $file\n"
                                    . "sub{ $self->{source} }";
                   my $diagnostic = $@;
                   $diagnostic =~ s{ \s*+ \bat \s++ \( eval \s++ \d++ \) \s++ line \s++ 0,
                                   | \s*+ \( eval \s++ \d++ \)
                                   | \s++ \Z
                                   | \s++ \bExecution \s++ of \s++ .*? \s++ aborted
                                     \s++ due \s++ to \s++ compilation \s++ errors\.
                                   }{}gx;
                   return $diagnostic;
                 }
}

# Define the grammar...
our $GRAMMAR = qr{
    (?(DEFINE)

        (?<PerlEntireDocument>   (?<PerlStdEntireDocument>
            \A
            (?&PerlDocument)
            (?:
                \Z
            |
                (?(?{ !defined $PPR::X::ERROR })
                    (?>(?&PerlOWSOrEND))  (?{pos()})  ([^\n]++)
                    (?{ $PPR::X::ERROR = PPR::X::ERROR->new(source => "$^N", prefix => substr($_, 0, $^R) ) })
                    (?!)
                )
            )
    )) # End of rule

        (?<PerlDocument>   (?<PerlStdDocument>
            \x{FEFF}?+                      # Optional BOM marker
            (?&PerlStatementSequence)
            (?&PerlOWSOrEND)
    )) # End of rule

        (?<PerlStatementSequence>   (?<PerlStdStatementSequence>
            (?>(?&PerlPodSequence))
            (?:
                (?&PerlStatement)
                (?&PerlPodSequence)
            )*+
    )) # End of rule

        (?<PerlStatement>   (?<PerlStdStatement>
            (?>
                (?>(?&PerlPodSequence))
                (?: (?>(?&PerlLabel)) (?&PerlOWSOrEND) )?+
                (?>(?&PerlPodSequence))
                (?>
                    (?&PerlKeyword)
                |
                    (?&PerlSubroutineDeclaration)
                |
                    (?&PerlMethodDeclaration)
                |
                    (?&PerlUseStatement)
                |
                    (?&PerlPackageDeclaration)
                |
                    (?&PerlClassDeclaration)
                |
                    (?&PerlFieldDeclaration)
                |
                    (?&PerlControlBlock)
                |
                    (?&PerlFormat)
                |
                    (?>(?&PerlExpression))          (?>(?&PerlOWS))
                    (?&PerlStatementModifier)?+     (?>(?&PerlOWSOrEND))
                    (?> ; | (?= \} | \z ))
                |
                    (?&PerlBlock)
                |
                    ;
                )

            | # A yada-yada...
                \.\.\. (?>(?&PerlOWSOrEND))
                (?> ; | (?= \} | \z ))

            | # Just a label...
                (?>(?&PerlLabel)) (?>(?&PerlOWSOrEND))
                (?> ; | (?= \} | \z ))

            | # Just an empty statement...
                (?>(?&PerlOWS)) ;

            | # An error (report it, if it's the first)...
                (?(?{ !defined $PPR::X::ERROR })
                    (?> (?&PerlOWS) )
                    (?! (?: \} | \z ) )