Devel-Declare-Lexer
view release on metacpan or search on metacpan
lib/Devel/Declare/Lexer.pm
lib/Devel/Declare/Lexer/Stream.pm
lib/Devel/Declare/Lexer/Token.pm
lib/Devel/Declare/Lexer/Tokens.pm
lib/Devel/Declare/Lexer/Factory.pm
lib/Devel/Declare/Lexer/Token/Bareword.pm
lib/Devel/Declare/Lexer/Token/Declarator.pm
lib/Devel/Declare/Lexer/Token/EndOfStatement.pm
lib/Devel/Declare/Lexer/Token/Heredoc.pm
lib/Devel/Declare/Lexer/Token/LeftBracket.pm
lib/Devel/Declare/Lexer/Token/Newline.pm
lib/Devel/Declare/Lexer/Token/Operator.pm
lib/Devel/Declare/Lexer/Token/Raw.pm
lib/Devel/Declare/Lexer/Token/RightBracket.pm
lib/Devel/Declare/Lexer/Token/String.pm
lib/Devel/Declare/Lexer/Token/String/Interpolator.pm
lib/Devel/Declare/Lexer/Token/Variable.pm
lib/Devel/Declare/Lexer/Token/Whitespace.pm
t/Factory.t
t/hashes.t
t/Lexer.t
t/Raw.t
t/bugs.t
t/strings.t
t/subs.t
t/inject.t
t/interpolate.t
t/deinterpolate.t
README
Makefile.PL
MANIFEST
example/example.pl
example/ExampleSyntax.pm
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
{
"abstract" : "Easier than Devel::Declare",
"author" : [
"Ian Kent <iankent@cpan.org>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "Devel-Declare-Lexer",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Devel::Declare" : "0.006011"
}
}
},
"release_status" : "stable",
"version" : "0.014"
}
---
abstract: 'Easier than Devel::Declare'
author:
- 'Ian Kent <iankent@cpan.org>'
build_requires:
ExtUtils::MakeMaker: 0
configure_requires:
ExtUtils::MakeMaker: 0
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: Devel-Declare-Lexer
no_index:
directory:
- t
- inc
requires:
Devel::Declare: 0.006011
version: 0.014
Makefile.PL view on Meta::CPAN
#!perl -w
###############################################################################
## ##
## Copyright (c) 2013 Ian Kent ##
## All rights reserved. ##
## ##
## This package is free software; you can redistribute it ##
## and/or modify it under the same terms as Perl itself. ##
## ##
###############################################################################
use strict;
use ExtUtils::MakeMaker;
BEGIN
{
eval { require Config_m; }; # ExtUtils::FakeConfig (+ ActivePerl)
eval { require Config; } # Everyone else
if ($@);
}
WriteMakefile(
'NAME' => 'Devel::Declare::Lexer',
'VERSION_FROM' => 'lib/Devel/Declare/Lexer.pm',
'ABSTRACT_FROM' => 'lib/Devel/Declare/Lexer.pm',
'LICENSE' => 'perl',
'AUTHOR' => 'Ian Kent <iankent@cpan.org>',
'PREREQ_PM' => {
'Devel::Declare' => 0.006011
},
'dist' => { COMPRESS => "gzip -9", SUFFIX => "gz" },
# for ActivePerl:
($] >= 5.005 && $^O eq 'MSWin32' && $Config::Config{'archname'} =~ /-object\b/i ?
('CAPI' => 'TRUE') : ())
);
__END__
=============================================
Package "Devel::Declare::Lexer" Version 0.014
=============================================
Abstract:
---------
This package provides an easy interface to Devel::Declare using a token
stream which can be manipulated at build time prior to parsing by the Perl
parser.
Copyright & License:
--------------------
This package with all its parts is
Copyright (c) 2013 Ian Kent
All rights reserved.
This package is free software; you can use, modify and redistribute
it under the same terms as Perl itself, i.e., at your option, under
the terms either of the "Artistic License" or the "GNU General Public
License".
Installation:
-------------
You can install directly from CPAN:
install Devel::Declare::Lexer
Alternatively, you can build and install the module yourself:
perl Makefile.PL
make
make test
make install
Under Windows, depending on your environment,
use "nmake" or "dmake" instead of "make".
Contact Author:
---------------
Ian Kent <iankent@cpan.org>
http://www.iankent.co.uk/
example/ExampleSyntax.pm view on Meta::CPAN
package ExampleSyntax;
BEGIN {
push @INC, '../lib';
}
use strict;
use warnings;
use Devel::Declare::Lexer qw/ debug function has auto_sprintf /;
use Devel::Declare::Lexer::Factory qw( :all );
BEGIN {
#$Devel::Declare::Lexer::DEBUG = 1;
Devel::Declare::Lexer::lexed(auto_sprintf => sub {
my ($stream_r) = @_;
my @stream = @$stream_r;
my @vars = $stream[4]->deinterpolate;
my @args = (
"%s",
"£%04d"
);
$stream[4]->{value} = $stream[4]->interpolate(@args);
my @start = @stream[0..3];
my @str = @stream[4..4];
my @end = @stream[5..$#stream];
push @start, (
new Devel::Declare::Lexer::Token::Bareword( value => 'sprintf' ),
new Devel::Declare::Lexer::Token::LeftBracket( value => '(' ),
);
unshift @end, (
new Devel::Declare::Lexer::Token::Operator( value => ',' ),
new Devel::Declare::Lexer::Token::Variable( value => $vars[0] ),
new Devel::Declare::Lexer::Token::Operator( value => ',' ),
new Devel::Declare::Lexer::Token::Variable( value => $vars[1] ),
new Devel::Declare::Lexer::Token::RightBracket( value => ')' ),
);
@stream = (@start, @str, @end);
return \@stream;
});
Devel::Declare::Lexer::lexed(debug => sub {
my ($stream_r) = @_;
my @stream = @$stream_r;
my $string = $stream[2]; # keyword [whitespace] "string"
my @ns = ();
tie @ns, "Devel::Declare::Lexer::Stream";
push @ns, (
new Devel::Declare::Lexer::Token::Declarator( value => 'debug' ),
new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ),
new Devel::Declare::Lexer::Token( value => 'print' ),
new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ),
$string,
new Devel::Declare::Lexer::Token::EndOfStatement,
new Devel::Declare::Lexer::Token::Newline,
);
return \@ns;
});
Devel::Declare::Lexer::lexed(function => sub {
my ($stream_r) = @_;
my @stream = @{$stream_r};
my @start = @stream[0..1];
my @end = @stream[2..$#stream];
my $name = shift @end; # get function name
# Capture the variables
my @vars = ();
# Consume everything until the start of block
while($end[0]->{value} !~ /{/) {
my $tok = shift @end;
next if ref($tok) =~ /Devel::Declare::Lexer::Token::(Left|Right)Bracket/;
next if ref($tok) =~ /Devel::Declare::Lexer::Token::Operator/;
next if ref($tok) =~ /Devel::Declare::Lexer::Token::Whitespace/;
# If we've got a variable, capture it
if(ref($tok) =~ /Devel::Declare::Lexer::Token::Variable/) {
push @vars, [
$tok,
shift @end
];
}
}
shift @end; # remove the {
# Build a sub with an opening my statement
my @output = _stream(\@start, [
_statement([_bareword(1)]),
_sub($name->{value}, [
_block([
_statement([
_bareword('my'),
_block([
_list(@vars)
], '('),
_operator('='),
_variable('@', '_')
]),
_stream(undef, \@end)
], '{', { no_close => 1 }), # don't close it ( #FIXME lexer bug, stops at first ; )
]),
]);
return \@output;
});
Devel::Declare::Lexer::lexed(has => sub {
my ($stream_r) = @_;
my @stream = @{$stream_r};
my @start = @stream[0..1];
my @end = @stream[2..$#stream];
shift @stream; # remove keyword
while(ref($stream[0]) =~ /Devel::Declare::Lexer::Token::Whitespace/) {
shift @stream;
}
# Get the name (could be string or variable)
my $name = shift @stream;
if(ref($name =~ /Devel::Declare::Lexer::Token::Variable/)) {
$name = shift @stream;
}
# Consume whitespace and =>
while($stream[0]->{value} !~ /{/) {
shift @stream;
}
my $nest = 0;
my @propblock = ();
shift @stream; # consume the {
while(@stream) {
if(ref($stream[0]) =~ /Devel::Declare::Lexer::Token::LeftBracket/) {
$nest++;
}elsif(ref($stream[0]) =~ /Devel::Declare::Lexer::Token::RightBracket/) {
last if $nest == 0 && $stream[0]->{value} =~ /}/;
$nest--;
}
push @propblock, shift @stream; # consume tokens
}
shift @stream; # consume the }
my @output = _stream($stream_r, [
_statement([_bareword(1)]),
_statement([
_bareword('my'),
_whitespace(' '),
_var_assign(
[_variable('$','__props_lexer_' . $name->{value})],
[_block([
@propblock
], '{')]
)
]),
_statement([
_var_assign(
[_variable('$','__props_lexer_' . $name->{value} . '->{\'value\'}')],
[_variable('$','__props_lexer_' . $name->{value} . '->{\'default\'}')]
)
]),
_sub(
$name->{value},
[_block([
_statement([
_bareword('my'),
_whitespace(' '),
_var_assign(
[_block([
_variable('$','value')
], '(')],
[_variable('@','_')]
)
]),
_if([
_variable('$','value'),
],
[
_var_assign(
[_variable('$','__props_lexer_' . $name->{value} . '->{\'value\'}')],
[_variable('$','value')]
)
]),
_return(
[_variable('$','__props_lexer_' . $name->{value} . '->{\'value\'}')]
)
])]
),
]);
# Stick everything else back on the end
push @output, @stream;
return \@output;
});
}
sub import
{
my $caller = caller;
Devel::Declare::Lexer::import_for($caller, "debug");
Devel::Declare::Lexer::import_for($caller, "function");
Devel::Declare::Lexer::import_for($caller, "has");
Devel::Declare::Lexer::import_for($caller, "auto_sprintf");
}
1;
example/example.pl view on Meta::CPAN
#!/perl
package ExampleUsage;
use ExampleSyntax;
use POSIX qw(strftime);
debug "This is a test\n";
function example ($a, $b) {
return $a + $b;
};
print "1 + 2 = " . example(1, 2) . "\n";
has 'a' => { is => 'rw', isa => 'Int', default => '123', random => 'abc' };
print "a is " . a . "\n";
a(15);
print "a is " . a . "\n";
function example2 ($a) {
return $a * a;
}
print "example2 = " . example2(10) . "\n";
my $str = 'sprintf';
my $num = 1.0362;
auto_sprintf print "This becomes a $str, num is 1.0362: $num \n";
lib/Devel/Declare/Lexer.pm view on Meta::CPAN
package Devel::Declare::Lexer;
use strict;
use warnings;
use v5;
our $VERSION = '0.014';
use Data::Dumper;
use Devel::Declare;
use Devel::Declare::Lexer::Stream;
use Devel::Declare::Lexer::Token;
use Devel::Declare::Lexer::Token::Bareword;
use Devel::Declare::Lexer::Token::Declarator;
use Devel::Declare::Lexer::Token::EndOfStatement;
use Devel::Declare::Lexer::Token::Heredoc;
use Devel::Declare::Lexer::Token::LeftBracket;
use Devel::Declare::Lexer::Token::Newline;
use Devel::Declare::Lexer::Token::Operator;
use Devel::Declare::Lexer::Token::RightBracket;
use Devel::Declare::Lexer::Token::String;
use Devel::Declare::Lexer::Token::Variable;
use Devel::Declare::Lexer::Token::Whitespace;
use vars qw/ @ISA $DEBUG $SHOWTRANSLATE /;
@ISA = ();
$DEBUG = 0;
$SHOWTRANSLATE = 0;
sub import
{
my $class = shift;
my $caller = caller;
import_for($caller, @_);
}
sub import_for
{
my ($caller, @args) = @_;
my $class = shift;
no strict 'refs';
my %subinject = ();
if(ref($args[0]) =~ /HASH/) {
$DEBUG and print STDERR "Using hash for import\n";
%subinject = %{$args[0]};
@args = keys %subinject;
}
my @consts;
my %tags = map { $_ => 1 } @args;
if($tags{":debug"}) {
$DEBUG = 1;
}
if($tags{":lexer_test"}) {
$DEBUG and print STDERR "Adding 'lexer_test' to keyword list\n";
push @consts, "lexer_test";
}
my @names = @args;
for my $name (@names) {
next if $name =~ /:/;
$DEBUG and print STDERR "Adding '$name' to keyword list\n";
push @consts, $name;
}
for my $word (@consts) {
$DEBUG and print STDERR "Injecting '$word' into '$caller'\n";
Devel::Declare->setup_for(
$caller,
{
$word => { const => \&lexer }
}
);
if($subinject{$word}) {
$DEBUG and print STDERR "- Using sub provided in import\n";
*{$caller.'::'.$word} = $subinject{$word};
} else {
$DEBUG and print STDERR "- Using default sub\n";
*{$caller.'::'.$word} = sub () { 1; };
}
}
}
my %named_lexed_stack = ();
sub lexed
{
my ($key, $callback) = @_;
$DEBUG and print STDERR "Registered callback for keyword '$key'\n";
$named_lexed_stack{$key} = $callback;
}
sub call_lexed
{
my ($name, $stream) = @_;
$DEBUG and print STDERR "Checking for callbacks for keyword '$name'\n";
$DEBUG and print STDERR Dumper($stream) . "\n";
my $callback = $named_lexed_stack{$name};
if($callback) {
$DEBUG and print STDERR "Found callback '$callback' for keyword '$name'\n";
$stream = &$callback($stream);
}
$DEBUG and print STDERR Dumper($stream) . "\n";
return $stream;
}
sub lexer
{
my ($symbol, $offset) = @_;
$DEBUG and print "=" x 80, "\n";
my $linestr = Devel::Declare::get_linestr;
my $original_linestr = $linestr;
my $original_offset = $offset;
$DEBUG and print STDERR "Starting with linestr '$linestr'\n";
my @tokens = ();
tie @tokens, "Devel::Declare::Lexer::Stream";
my ($len, $tok);
my $eoleos = 0;
my $line = 1;
# Skip the declarator
$offset += Devel::Declare::toke_move_past_token($offset);
push @tokens, new Devel::Declare::Lexer::Token::Declarator( value => $symbol );
$DEBUG and print STDERR "Skipped declarator '$symbol'\n";
my %lineoffsets = ( 1 => $offset );
# We call this from a few places inside the loop
my $skipspace = sub {
# Move past any whitespace
$len = Devel::Declare::toke_skipspace($offset);
if($len > 0) {
$tok = substr($linestr, $offset, $len);
$DEBUG and print STDERR "Skipped whitespace '$tok', length [$len]\n";
push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => $tok );
$offset += $len;
if($tok =~ /\n/) {
# its odd that this works without handling any line numbering
# I think we end up here when an end of line is found after a bareword (e.g. print\n"something")
# It probably still needs some work on line numbering, but everything just seems to work!
$DEBUG and print STDERR "Got end of line in skipspace, probable bareword preceeding EOL\n";
Devel::Declare::clear_lex_stuff;
# We've got a new line so we need to refresh our linestr
$linestr = Devel::Declare::get_linestr;
$original_linestr = $linestr;
$DEBUG and print STDERR "Refreshed linestr [$linestr]\n";
}
} elsif ($len < 0) {
# Again, its odd that we don't handle any line numbering here, and a $len of < 0 is a definite EOL
$DEBUG and print STDERR "Got end of line in skipspace\n";
} elsif ($len == 0) {
$DEBUG and print STDERR "No whitespace skipped\n";
}
return $len;
};
# Capture the tokens
$DEBUG and print STDERR "Linestr length [", length $linestr, "]\n";
my $heredoc = undef;
my $heredoc_end_re = undef;
my $heredoc_end_re2 = undef;
my $nest = 0; # nested bracket tracking, just in case we get ; inside a block
while($offset < length $linestr) {
$DEBUG and print STDERR Dumper(\%lineoffsets) . "\n";
if($heredoc && !(substr($linestr, $offset, 2) eq "\n")) {
my $c = substr($linestr, $offset, 1);
$DEBUG and print STDERR "Consuming char from heredoc: '$c'\n";
$offset += 1;
if($c =~ /\n/) {
$DEBUG and print STDERR "Newline found in heredoc (current line $line)\n";
#$line++;
#$lineoffsets{$line} = $offset;
} else {
$heredoc->{value} .= $c;
}
$DEBUG and print STDERR "New heredoc value: " . $heredoc->{value} . "\n";
my $heredoc_name = $heredoc->{name};
if($heredoc->{value} =~ /$heredoc_end_re/) {
$heredoc->{value} =~ s/$heredoc_end_re2//;
$DEBUG and print STDERR "Consumed heredoc, name [$heredoc_name]:\n" . $heredoc->{value} . "\n";
push @tokens, $heredoc;
$heredoc = undef;
$heredoc_end_re = undef;
$heredoc_end_re2 = undef;
}
next;
}
$DEBUG and print STDERR "Offset[$offset], nest [$nest], Remaining[", substr($linestr, $offset), "]\n";
if(substr($linestr, $offset, 1) eq ';') {
$DEBUG and print STDERR "Got end of statement\n";
push @tokens, new Devel::Declare::Lexer::Token::EndOfStatement;
$offset += 1;
$eoleos = 1;
last unless $nest;
next;
}
if(substr($linestr, $offset, 2) eq "\n") {
if($heredoc) {
$DEBUG and print STDERR "Got end of line in heredoc\n";
$heredoc->{value} .= "\n";
}
if(!$heredoc) {
$DEBUG and print STDERR "Got end of line in loop (current line $line)\n";
push @tokens, new Devel::Declare::Lexer::Token::Newline;
$offset += 1;
}
# this lets us capture a newline directly after a semicolon
# and immediately exit the loop - otherwise we might start
# consuming code that doesn't belong to us
last if $eoleos && !$nest;
$eoleos = 0;
# If we're here, it's just a new line inside the statement that
# we do want to consume
# We don't use skipspace here - it does too much!
#&$skipspace;
$len = Devel::Declare::toke_skipspace($offset);
if($len != 0) {
# TODO it seems odd that we don't add $len to the
# offset... this might come back to bite us later!
#$offset += $len - 6;
$DEBUG and print STDERR "Skipped $len whitespace following EOL, not added to \$offset\n";
}
Devel::Declare::clear_lex_stuff;
# Got a new line, so we need to refresh linestr
$linestr = Devel::Declare::get_linestr;
# It's not the next line, its everything upto and including the next line
# so really our original_linestr is wrong!
$original_linestr = $linestr;
# Record some offsets for later - we start on line 1 and the first $line++ is 2
# so we make a special case for recording line 1's offset
if($line == 1) {
$lineoffsets{1} = (length $symbol) + 1;
};
$line++;
$lineoffsets{$line} = $heredoc ? $offset + 1 : $offset;
$DEBUG and print STDERR "Refreshed linestr [$linestr], added lineoffset for line $line, offset $offset\n";
next;
}
# FIXME Does this ever happen?
if(&$skipspace < 0) {
$DEBUG and print STDERR "Got skipspace < 0\n";
last;
}
# Check if its a opening bracket
if(substr($linestr, $offset, 1) =~ /(\{|\[|\()/) {
my $b = substr($linestr, $offset, 1);
push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => $b );
$nest++;
$DEBUG and print STDERR "Got left bracket '$b', nest[$nest]\n";
$offset += 1;
next;
}
# Check if its a closing bracket
if(substr($linestr, $offset, 1) =~ /(\}|\]|\))/) {
my $b = substr($linestr, $offset, 1);
push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => $b );
$nest--;
$DEBUG and print STDERR "Got right bracket '$b', nest[$nest]\n";
$offset += 1;
next;
}
# Check for a reference
if(substr($linestr, $offset, 1) =~ /\\/) {
$tok = substr($linestr, $offset, 1);
$DEBUG and print STDERR "Got reference operator '$tok'\n";
push @tokens, new Devel::Declare::Lexer::Token::Operator( value => $tok);
$offset += 1;
next;
}
# Check for variable
if(substr($linestr, $offset, 1) =~ /(\$|\%|\@|\*)/) {
# get the sign
# TODO the variable name is captured later - it should probably be done here
$tok = substr($linestr, $offset, 1);
$DEBUG and print STDERR "Got variable '$tok'\n";
push @tokens, new Devel::Declare::Lexer::Token::Variable( value => $tok );
$offset += 1;
next;
}
# Check for string
if(substr($linestr, $offset, 1) =~ /^(q|\"|\')/) {
# FIXME need to determine string type properly
my $strstype = substr($linestr, $offset, 1);
my $allow_string = 1;
if($strstype eq 'q') {
if(substr($linestr, $offset + 1, 1) !~ /\|\{\[\(\#/) {
$DEBUG and print STDERR "This 'q' isnt a string type\n";
$allow_string = 0;
}
}
if($allow_string) {
my $stretype = $strstype;
if($strstype =~ /q/) {
if(substr($linestr, $offset, 2) =~ /qq/) {
$strstype = substr($linestr, $offset, 3);
$offset += 2;
} else {
$strstype = substr($linestr, $offset, 2);
$offset += 1;
}
$stretype = substr($linestr, $offset, 1);
$stretype =~ tr/\(/)/;
$len = Devel::Declare::toke_scan_str($offset);
} else {
$len = Devel::Declare::toke_scan_str($offset);
}
$DEBUG and print STDERR "Got string type '$strstype', end type '$stretype'\n";
$tok = Devel::Declare::get_lex_stuff;
Devel::Declare::clear_lex_stuff;
$DEBUG and print STDERR "Got string '$tok'\n";
push @tokens, new Devel::Declare::Lexer::Token::String( start => $strstype, end => $stretype, value => $tok );
# get a new linestr - we might have captured multiple lines
$linestr = Devel::Declare::get_linestr;
$offset += $len;
# If we do have multiple lines, we'll fix line numbering at the end
next;
}
}
# Check for heredoc
if(substr($linestr, $offset)=~ /^(<<\s*([\w\d]+)\s*\n)/) {
# Heredocs are weird - we'll just remember we're in a heredoc until we get the end token
$DEBUG and print STDERR "Got a heredoc with name '$2'\n";
$heredoc = new Devel::Declare::Lexer::Token::Heredoc( name => $2, value => '' );
$heredoc_end_re = qr/\n$2\n$/;
$heredoc_end_re2 = qr/$2\n$/;
$DEBUG and print STDERR "Created regex $heredoc_end_re and $heredoc_end_re2\n";
# get a new linestr - we might have captured multiple lines
$offset += 2 + (length $1);
$len = Devel::Declare::toke_skipspace($offset);
$linestr = Devel::Declare::get_linestr;
$offset += $len;
$DEBUG and print STDERR "Skipped $len whitespace at start of heredoc, got new linestr[$linestr]\n";
$line++;
$lineoffsets{$line} = $offset;
# If we do have multiple lines, we'll fix line numbering at the end
next;
}
# Check for operator after strings (so heredocs <<NAME work)
if(substr($linestr, $offset, 1) =~ /[!\+\-\*\/\.><=,|&\?:]/) {
$tok = substr($linestr, $offset, 1);
$DEBUG and print STDERR "Got operator '$tok'\n";
push @tokens, new Devel::Declare::Lexer::Token::Operator( value => $tok );
$offset += 1;
next;
}
# Check for bareword
$len = Devel::Declare::toke_scan_word($offset, 1);
if($len) {
$tok = substr($linestr, $offset, $len);
$DEBUG and print STDERR "Got bareword '$tok'\n";
push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => $tok );
$offset += $len;
next;
}
}
# Callback (AT COMPILE TIME) to allow manipulation of the token stream before injection
$DEBUG and print STDERR Dumper(\@tokens) . "\n";
@tokens = @{call_lexed($symbol, \@tokens)};
my $stmt = "";
for my $token (@tokens) {
$stmt .= $token->get;
}
$DEBUG and print "=" x 80, "\n";
if($symbol =~ /^lexer_test$/) {
$DEBUG and print STDERR "Escaping statement for variable assignment\n";
$stmt =~ s/\\/\\\\/g;
$stmt =~ s/\"/\\"/g;
$stmt =~ s/\$/\\\$/g;
$stmt =~ s/\n/\\n/g;
chomp $stmt;
$stmt = substr($stmt, 0, (length $stmt)); # strip the final \\n
} else {
$stmt =~ s/\n//g; # remove multiline on final statement
chomp $stmt;
}
$DEBUG and print STDERR "Final statement: [$stmt]\n";
# FIXME line numbering is broken if a \n appears inside a block, e.g. keyword { print "\n"; }
#my @lcnt = split /[^\\]\\n/, $stmt;
my @lcnt = split /\\n/, $stmt;
my $lc = scalar @lcnt;
$DEBUG and print STDERR "Lines:\n", Dumper(\@lcnt) . "\n";
my $lineadjust = $lc - $line;
$DEBUG and print STDERR "Linecount[$lc] lines[$line] - missing $lineadjust lines\n";
# we've got a new linestr, we need to re-fix all our offsets
$DEBUG and print STDERR "\n\nStarted with linestr [$linestr]\n";
use Data::Dumper;
$DEBUG and print STDERR Dumper(\%lineoffsets) . "\n";
for my $l (sort keys %lineoffsets) {
my $sol = $lineoffsets{$l};
last if !defined $lineoffsets{$l+1}; # don't mess with the current line, yet!
my $eol = $lineoffsets{$l + 1} - 1;
my $diff = $eol - $sol;
my $substr = substr($linestr, $sol, $diff);
$DEBUG and print STDERR "\nLine $l, sol[$sol], eol[$eol], diff[$diff], linestr[$linestr], substr[$substr]\n";
substr($linestr, $sol, $diff) = " " x $diff;
}
# now clear up the last line
$DEBUG and print STDERR "Still got linestr[$linestr]\n";
my $sol = $line == 1 ? (length $symbol) + 1 + $original_offset : $lineoffsets{$line};
my $eol = (length $linestr) - 1;
my $diff = $eol - $sol;
my $substr = substr($linestr, $sol, $diff);
$DEBUG and print STDERR "Got substr[$substr] sol[$sol] eol[$eol] diff[$diff]\n";
my $newline = "\n" x $lineadjust;
if($symbol =~ /^lexer_test$/) {
$newline .= "and \$lexed = \"$stmt\";";
} else {
$newline .= " and " . substr($stmt, length $symbol);
}
substr($linestr, $sol, (length $linestr) - $sol - 1) = $newline; # put the rest of the statement in
($DEBUG || $SHOWTRANSLATE) and print STDERR "Got new linestr[$linestr] from original_linestr[$original_linestr]\n";
$DEBUG and print "=" x 80, "\n";
Devel::Declare::set_linestr($linestr);
}
1;
=encoding utf8
=head1 NAME
Devel::Declare::Lexer - Easier than Devel::Declare
=head1 SYNOPSIS
# Add :debug tag to enable debugging
# Add :lexer_test to enable variable assignment
# Anything not starting with : becomes a keyword
use Devel::Declare::Lexer qw/ keyword /;
BEGIN {
# Create a callback for the keyword (inside a BEGIN block!)
Devel::Declare::Lexer::lexed(keyword => sub {
# Get the stream out (given as an arrayref)
my ($stream_r) = @_;
my @stream = @$stream_r;
my $str = $stream[2]; # in the example below, the string is the 3rd token
# Create a new stream (we could manipulate the existing one though)
my @ns = ();
tie @ns, "Devel::Declare::Lexer::Stream";
# Add a few tokens to print the string
push @ns, (
# You need this (for now)
new Devel::Declare::Lexer::Token::Declarator( value => 'keyword' ),
new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ),
# Everything else is your own custom code
new Devel::Declare::Lexer::Token( value => 'print' ),
new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ),
$string,
new Devel::Declare::Lexer::Token::EndOfStatement,
new Devel::Declare::Lexer::Token::Newline,
);
# Stream now contains:
# keyword and print "This is a string";
# keyword evaluates to 1, everything after the and gets executed
# Return an arrayref
return \@ns;
});
}
# Use the keyword anywhere in this package
keyword "This is a string";
=head1 DESCRIPTION
L<Devel::Declare::Lexer> makes it easier to parse code using L<Devel::Declare>
by generating a token stream from the statement and providing a callback for
you to manipulate it before its parsed by Perl.
The example in the synopsis creates a keyword named 'keyword', which accepts
a string and prints it.
Although this simple example could be done using print, say or any other simple
subroutine, L<Devel::Declare::Lexer> supports much more flexible syntax.
For example, it could be used to auto-expand subroutine declarations, e.g.
method MethodName ( $a, @b ) {
...
}
into
sub MethodName ($@) {
my ($self, $a, @b) = @_;
...
}
Unlike L<Devel::Declare>, there's no need to worry about parsing text and
taking care of multiline strings or code blocks - it's all done for you.
=head1 ADVANCED USAGE
L<Devel::Declare::Lexer>'s standard behaviour is to inject a sub into the
calling package which returns a 1. Because your statement typically gets
transformed into something like
keyword and [your statement here];
the fact keyword evaluates to 1 means everything following the and will always
be executed.
You can extend this by using a different import syntax when loading L<Devel::Declare::Lexer>
use Devel::Declare::Lexer { keyword => sub { $Some::Package::variable } };
which will cause the provided sub to be injected instead of the default sub.
=head1 SEE ALSO
Some examples can be found in the source download.
For more information about how L<Devel::Declare::Lexer> works, read the
documentation for L<Devel::Declare>.
=head1 AUTHORS
Ian Kent - L<iankent@cpan.org> - original author
http://www.iankent.co.uk/
=head1 COPYRIGHT AND LICENSE
This library is free software under the same terms as perl itself
Copyright (c) 2013 Ian Kent
Devel::Declare::Lexer is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
=cut
lib/Devel/Declare/Lexer/Factory.pm view on Meta::CPAN
package Devel::Declare::Lexer::Factory;
use Devel::Declare::Lexer::Stream;
use Devel::Declare::Lexer::Tokens;
use v5;
our (@ISA, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw( _stream _statement _reference _variable _string _var_assign _list _keypair _if _return _bareword _block _sub _whitespace _operator );
%EXPORT_TAGS = (
'all' => \@EXPORT_OK
);
}
sub _stream
{
my ($old_stream, $new_stream) = @_;
my @stream = ();
tie @stream, 'Devel::Declare::Lexer::Stream';
if($old_stream) {
push @stream, shift @$old_stream; # declarator
push @stream, shift @$old_stream; # whitespace
}
if($new_stream) {
push @stream, @$new_stream;
}
return @stream;
}
sub _statement
{
my ($tokens) = @_;
my @t = ();
push @t, @$tokens;
push @t, new Devel::Declare::Lexer::Token::EndOfStatement;
return @t;
}
sub _reference
{
my ($refto) = @_;
my @tokens = ();
push @tokens, new Devel::Declare::Lexer::Token::Operator( value => '\\' );
push @tokens, @$refto;
return @tokens;
}
sub _operator
{
my ($operator) = @_;
return ( new Devel::Declare::Lexer::Token::Operator( value => $operator ) );
}
sub _variable
{
my ($sigil, $name) = @_;
my @tokens = ();
while($sigil) {
push @tokens, new Devel::Declare::Lexer::Token::Variable( value => substr($sigil, 0, 1) );
$sigil = substr($sigil, 1);
}
push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => $name );
return @tokens;
}
sub _bareword
{
my ($word) = @_;
return ( new Devel::Declare::Lexer::Token::Bareword( value => $word ) );
}
sub _string
{
my ($type, $value) = @_;
return ( new Devel::Declare::Lexer::Token::String( start => $type, end => $type, value => $value ) );
}
sub _var_assign
{
my ($var, $value) = @_;
my @tokens = ();
push @tokens, @$var;
push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
push @tokens, new Devel::Declare::Lexer::Token::Operator( value => '=' );
push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
if(ref($value) =~ /ARRAY/) {
push @tokens, @$value;
} else {
push @tokens, $value;
}
return @tokens;
}
sub _list
{
my @items = @_;
my @tokens = ();
for my $item (@items) {
if(ref($item) =~ /ARRAY/) {
push @tokens, @$item;
} else {
push @tokens, $item;
}
push @tokens, new Devel::Declare::Lexer::Token::Operator( value => ',' );
push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
}
# Remove additional ,\s
pop @tokens;
pop @tokens;
return @tokens;
}
sub _keypair
{
my ($var1, $var2) = @_;
my @tokens = ();
push @tokens, @$var1;
push @tokens, @$var2;
return @tokens;
}
sub _return
{
my ($value) = @_;
my @tokens = ();
push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'return' );
push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
push @tokens, @$value;
return @tokens;
}
sub _block
{
my ($inner, $type, $args) = @_;
$type = $type || '{';
my $etype = $type;
$etype =~ tr/{([/})]/;
my @tokens = ();
push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => $type );
push @tokens, @$inner;
if(!$args->{no_close}) {
push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => $etype );
}
return @tokens;
}
sub _whitespace
{
my ($ws) = @_;
return ( new Devel::Declare::Lexer::Token::Whitespace( value => $ws ) );
}
sub _sub
{
my ($name, $block) = @_;
my @tokens = ();
push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'sub' );
push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => $name );
push @tokens, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
push @tokens, @$block;
return @tokens;
}
sub _if
{
my ($condition, $then, $elsifs, $else) = @_;
my @tokens = ();
push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'if' );
push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '(' );
push @tokens, @$condition;
push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => ')' );
push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' );
push @tokens, @$then;
push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' );
if($elsifs) {
my @elsif = @$elsifs;
if(scalar @elsif > 0) {
for my $eif (@elsif) {
push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'elsif' );
push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '(' );
push @tokens, @{$eif->{condition}};
push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => ')' );
push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' );
push @tokens, @{$eif->{then}};
push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' );
}
}
}
if($else) {
push @tokens, new Devel::Declare::Lexer::Token::Bareword( value => 'else' );
push @tokens, new Devel::Declare::Lexer::Token::LeftBracket( value => '{' );
push @tokens, @$else;
push @tokens, new Devel::Declare::Lexer::Token::RightBracket( value => '}' );
}
return @tokens;
}
1;
lib/Devel/Declare/Lexer/Stream.pm view on Meta::CPAN
package Devel::Declare::Lexer::Stream;
use v5;
use Tie::Array;
our @ISA = ('Tie::StdArray');
1;
lib/Devel/Declare/Lexer/Token.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = bless {
%arg
}, $caller;
return $self;
}
sub get
{
my ($self) = @_;
return $self->{value};
}
1;
lib/Devel/Declare/Lexer/Token/Bareword.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::Bareword;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
1;
lib/Devel/Declare/Lexer/Token/Declarator.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::Declarator;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
1;
lib/Devel/Declare/Lexer/Token/EndOfStatement.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::EndOfStatement;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(
value => ';',
%arg,
);
return $self;
}
1;
lib/Devel/Declare/Lexer/Token/Heredoc.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::Heredoc;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
sub get
{
my ($self) = @_;
# return '<<' . $self->{name} . "\n" . $self->{value}; # value currently contains end name
my $v = $self->{value};
$v =~ s/\n/\\n/g;
return '"' . $v . '"'; # value currently contains end name
}
1;
lib/Devel/Declare/Lexer/Token/LeftBracket.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::LeftBracket;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
1;
lib/Devel/Declare/Lexer/Token/Newline.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::Newline;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(
value => "\n",
%arg,
);
return $self;
}
1;
lib/Devel/Declare/Lexer/Token/Operator.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::Operator;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
1;
lib/Devel/Declare/Lexer/Token/Raw.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::Raw;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
sub get
{
my ($self) = @_;
return $self->{value};
}
1;
lib/Devel/Declare/Lexer/Token/RightBracket.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::RightBracket;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
1;
lib/Devel/Declare/Lexer/Token/String.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::String;
use base qw/ Devel::Declare::Lexer::Token /;
use Devel::Declare::Lexer::Token::String::Interpolator;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
sub get
{
my ($self) = @_;
my $v = $self->{value};
$v =~ s/\n/\\n/g;
return $self->{start} . $v . $self->{end};
}
sub deinterpolate
{
my ($self) = @_;
return Devel::Declare::Lexer::Token::String::Interpolator::deinterpolate($self->{value});
}
sub interpolate
{
my ($self, @args) = @_;
return Devel::Declare::Lexer::Token::String::Interpolator::interpolate($self->{value}, @args);
}
1;
lib/Devel/Declare/Lexer/Token/String/Interpolator.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::String::Interpolator;
use strict;
use warnings;
use Data::Dumper;
my $DEBUG = $Devel::Declare::Lexer::DEBUG;
sub interpolate {
my ($string, @values) = @_;
my $vars = deinterpolate($string);
my @varlist = (@$vars);
$DEBUG and print STDERR Dumper(@varlist) . "\n";
my $i = 0;
$DEBUG and print STDERR "old string: $string\n";
my $offset = 0;
for my $var (@varlist) {
$DEBUG and print STDERR "offset: $offset\n";
substr( $string, $var->{start} + $offset, $var->{length} ) = $values[$i];
my $oldlen = $var->{length};
my $newlen = length $values[$i];
$offset += ($newlen - $oldlen);
$DEBUG and print STDERR "new offset: $offset\n";
$i++;
}
$DEBUG and print STDERR "new string: $string\n";
return $string;
}
sub deinterpolate {
my ($string) = @_;
my @vars = ();
$DEBUG and print STDERR "Deinterpolating '$string'\n";
my @chars = split //, $string;
my @procd = ();
my $tok = '';
my $pos = -1;
for my $char (@chars) {
push @procd, $char;
$pos++;
$DEBUG and print STDERR "Got char '$char' at pos $pos\n";
if($char =~ /[^\w_{}\[\]:@\$]/ && $tok) {
$DEBUG and print STDERR "Captured token '$tok' at pos $pos (eot)\n";
push @vars, {
token => $tok,
start => $pos - (length $tok),
end => $pos,
length => (length $tok)
};
$tok = '';
next;
}
#if($tok && ($char !~ /[\$\@\%]/ || length $tok == 1)) {
if($tok && ($char !~ /[\$\@]/ || length $tok == 1)) {
$DEBUG and print STDERR "Got tok '$tok' so far\n";
my $eot = 0;
if($char =~ /[':]/) {
# do some forwardlooking
my $c = $chars[$pos + 1];
#if($c && $c =~ /[\s\$\%\@]/) {
if($c && $c =~ /[\s\$\@]/) { # hashes are only interpolated with $name{key} syntax
$eot = 1;
}
}
if(!$eot) {
$tok .= $char;
next;
}
}
#if($char =~ /[\$\@\%]/ || $tok) {
if($char =~ /[\$\@]/ || $tok) {
#if($char =~ /[\$\@\%]/ && $tok && $tok !~ /^[\$\@\%]+$/) {
if( $tok && (($char =~ /[\$\@]/ && $tok !~ /^[\$\@]+$/))) {
$DEBUG and print STDERR "Captured token '$tok' at pos $pos\n";
push @vars, {
token => $tok,
start => $pos - (length $tok),
end => $pos,
length => (length $tok)
};
$tok = '';
}
my $capture = 0;
$DEBUG and print STDERR "Got tok '$tok' in varcap\n";
if(!$tok) {
# do some backtracking
my $ec = 0;
for(my $i = $pos - 1; $i >= 0; $i--) {
my $c = $procd[$i];
last if $c !~ /\\/;
$ec++;
$DEBUG and print STDERR "Got char '$c' at pos $i, ec $ec\n";
}
$capture = $ec % 2 == 0 ? 1 : 0;
#if($ec % 2 == 0) {
# print "probably a token\n";
#} else {
# print "probably not a token\n";
#}
}
$DEBUG and print STDERR "Got capture $capture\n\n";
$tok = $char if $capture;
next;
}
}
if(wantarray) {
$DEBUG and print STDERR "Returning array of token names\n";
return map { $_->{token} } @vars;
}
$DEBUG and print STDERR "Returning arrayref\n";
return \@vars;
}
1;
lib/Devel/Declare/Lexer/Token/Variable.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::Variable;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
1;
lib/Devel/Declare/Lexer/Token/Whitespace.pm view on Meta::CPAN
package Devel::Declare::Lexer::Token::Whitespace;
use base qw/ Devel::Declare::Lexer::Token /;
use v5;
sub new
{
my ($caller, %arg) = @_;
my $self = $caller->SUPER::new(%arg);
return $self;
}
1;
lib/Devel/Declare/Lexer/Tokens.pm view on Meta::CPAN
package Devel::Declare::Lexer::Tokens;
use Devel::Declare::Lexer::Token;
use Devel::Declare::Lexer::Token::Bareword;
use Devel::Declare::Lexer::Token::Declarator;
use Devel::Declare::Lexer::Token::EndOfStatement;
use Devel::Declare::Lexer::Token::Heredoc;
use Devel::Declare::Lexer::Token::LeftBracket;
use Devel::Declare::Lexer::Token::Newline;
use Devel::Declare::Lexer::Token::Operator;
use Devel::Declare::Lexer::Token::Raw;
use Devel::Declare::Lexer::Token::RightBracket;
use Devel::Declare::Lexer::Token::String;
use Devel::Declare::Lexer::Token::Variable;
use Devel::Declare::Lexer::Token::Whitespace;
1;
t/Factory.t view on Meta::CPAN
#!/usr/bin/perl
package Devel::Declare::Lexer::Factory::t;
use strict;
use warnings;
use Devel::Declare::Lexer qw/ test function has /;
use Devel::Declare::Lexer::Factory qw/ _stream _statement _reference _variable _string _var_assign _list _keypair _if _return _bareword _block _whitespace _operator _sub /;
use Test::More;
#BEGIN { $Devel::Declare::Lexer::DEBUG = 1; }
my $tests = 0;
BEGIN {
Devel::Declare::Lexer::lexed(test => sub {
my ($stream_r) = @_;
# Create a new stream from the old one (consumes declarator and whitespace)
my @stream = _stream($stream_r,[
# Create a new statement (passing in array ref of tokens)
_statement([
# Create a variable assignment, passing in a array ref variable and a token value
_var_assign(
# Create an array ref variable
[_variable('$', 'test')],
# Create a new string
_string( "'", "123" )
)
])
]);
return \@stream;
});
Devel::Declare::Lexer::lexed(function => sub {
my ($stream_r) = @_;
my @stream = @{$stream_r};
my @start = @stream[0..1];
my @end = @stream[2..$#stream];
my $name = shift @end; # get function name
# Capture the variables
my @vars = ();
# Consume everything until the start of block
while($end[0]->{value} !~ /{/) {
my $tok = shift @end;
next if ref($tok) =~ /Devel::Declare::Lexer::Token::(Left|Right)Bracket/;
next if ref($tok) =~ /Devel::Declare::Lexer::Token::Operator/;
next if ref($tok) =~ /Devel::Declare::Lexer::Token::Whitespace/;
# If we've got a variable, capture it
if(ref($tok) =~ /Devel::Declare::Lexer::Token::Variable/) {
push @vars, [
$tok,
shift @end
];
}
}
shift @end; # remove the {
# Build a sub with an opening my statement
my @output = _stream(\@start, [
_statement([_bareword(1)]),
_sub($name->{value}, [
_block([
_statement([
_bareword('my'),
_block([
_list(@vars)
], '('),
_operator('='),
_variable('@', '_')
]),
_stream(undef, \@end)
], '{', { no_close => 1 }), # don't close it ( #FIXME lexer bug, stops at first ; )
]),
]);
return \@output;
});
Devel::Declare::Lexer::lexed(has => sub {
my ($stream_r) = @_;
my @stream = @{$stream_r};
my @start = @stream[0..1];
my @end = @stream[2..$#stream];
shift @stream; # remove keyword
while(ref($stream[0]) =~ /Devel::Declare::Lexer::Token::Whitespace/) {
shift @stream;
}
# Get the name (could be string or variable)
my $name = shift @stream;
if(ref($name =~ /Devel::Declare::Lexer::Token::Variable/)) {
$name = shift @stream;
}
# Consume whitespace and =>
while($stream[0]->{value} !~ /{/) {
shift @stream;
}
my $nest = 0;
my @propblock = ();
shift @stream; # consume the {
while(@stream) {
if(ref($stream[0]) =~ /Devel::Declare::Lexer::Token::LeftBracket/) {
$nest++;
}elsif(ref($stream[0]) =~ /Devel::Declare::Lexer::Token::RightBracket/) {
last if $nest == 0 && $stream[0]->{value} =~ /}/;
$nest--;
}
push @propblock, shift @stream; # consume tokens
}
shift @stream; # consume the }
my @output = _stream($stream_r, [
_statement([_bareword(1)]),
_statement([
_bareword('my'),
_whitespace(' '),
_var_assign(
[_variable('$','__props_lexer_' . $name->{value})],
[_block([
@propblock
], '{')]
)
]),
_statement([
_var_assign(
[_variable('$','__props_lexer_' . $name->{value} . '->{\'value\'}')],
[_variable('$','__props_lexer_' . $name->{value} . '->{\'default\'}')]
)
]),
_sub(
$name->{value},
[_block([
_statement([
_bareword('my'),
_whitespace(' '),
_var_assign(
[_block([
_variable('$','value')
], '(')],
[_variable('@','_')]
)
]),
_if([
_variable('$','value'),
],
[
_var_assign(
[_variable('$','__props_lexer_' . $name->{value} . '->{\'value\'}')],
[_variable('$','value')]
)
]),
_return(
[_variable('$','__props_lexer_' . $name->{value} . '->{\'value\'}')]
)
])]
),
]);
# Stick everything else back on the end
push @output, @stream;
return \@output;
});
}
my $test;
test "a b c";
++$tests && is($test, '123', 'Using factory methods');
function something ($a, $b) {
return 5 * ($a + $b);
};
++$tests && is(something(1,2), 15, 'Function definition');
has 'a' => { is => 'rw', isa => 'Int', default => '123', random => 'abc' };
++$tests && is(a, 123, 'Property construct and value get');
a(50);
++$tests && is(a, 50, 'Property value set');
++$tests && is(__LINE__, 189, 'Line numbering (CHECK WHICH LINE THIS IS ON)');
done_testing $tests;
#100 / 0;
#!/usr/bin/perl
package Devel::Declare::Lexer::t;
use strict;
use warnings;
#use Devel::Declare::Lexer qw/ :lexer_test /; # creates a lexer_test keyword and places lexed code into runtime $lexed
use Devel::Declare::Lexer qw/ :lexer_test lexer_test2 /; # creates a lexer_test keyword and places lexed code into runtime $lexed
use Test::More;
#BEGIN { $Devel::Declare::Lexer::DEBUG = 1; }
my $tests = 0;
my $lexed;
BEGIN {
Devel::Declare::Lexer::lexed(lexer_test2 => sub {
my ($stream_r) = @_;
my @stream = @$stream_r;
my $string = $stream[2]; # keyword [whitespace] "string"
$string->{value} =~ tr/pi/do/;
my @ns = ();
tie @ns, "Devel::Declare::Lexer::Stream";
push @ns, (
new Devel::Declare::Lexer::Token::Declarator( value => 'lexer_test2' ),
new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ),
new Devel::Declare::Lexer::Token( value => 'my' ),
new Devel::Declare::Lexer::Token::Variable( value => '$lexer_test2'),
new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ),
new Devel::Declare::Lexer::Token::Operator( value => '=' ),
new Devel::Declare::Lexer::Token::Whitespace( value => ' ' ),
$string,
new Devel::Declare::Lexer::Token::EndOfStatement,
new Devel::Declare::Lexer::Token::Newline,
);
return \@ns;
});
}
lexer_test2 "pigs in blankets";
++$tests && is($lexer_test2, q|dogs on blankets|, 'Lexer callback');
lexer_test "this is a test";
++$tests && is($lexed, q|lexer_test "this is a test";|, 'Strings');
lexer_test "this", "is", "another", "test";
++$tests && is($lexed, q|lexer_test "this", "is", "another", "test";|, 'List of strings');
lexer_test { "this", "is", "a", "test" };
++$tests && is($lexed, q|lexer_test { "this", "is", "a", "test" };|, 'Hashref list of strings');
lexer_test ( "this", "is", "a", "test" );
++$tests && is($lexed, q|lexer_test ( "this", "is", "a", "test" );|, 'Array of strings');
my $a = 1;
lexer_test ( $a + $a );
++$tests && is($lexed, q|lexer_test ( $a + $a );|, 'Variables and operators');
lexer_test ( $a != $a );
++$tests && is($lexed, q|lexer_test ( $a != $a );|, 'Inequality operator');
my $longer_name = 1234;
lexer_test ( !$longer_name );
++$tests && is($lexed, q|lexer_test ( !$longer_name );|, 'Negative operator and complex variable names');
lexer_test ( \$longer_name );
++$tests && is($lexed, q|lexer_test ( \$longer_name );|, 'Referencing operator');
my $ln_ref = \$longer_name;
lexer_test ( $$ln_ref );
++$tests && is($lexed, q|lexer_test ( $$ln_ref );|, 'Dereferencing operator');
lexer_test q(this is a string);
++$tests && is($lexed, q|lexer_test q(this is a string);|, 'q quoting operator');
lexer_test abc();
++$tests && is($lexed, q|lexer_test abc();|, 'sub call with parentheses');
lexer_test q(this
is
a
multiline);
++$tests && is($lexed, qq|lexer_test q(this\nis\na\nmultiline);|, 'q quoting operator with multiline');
lexer_test ( {
abc => 2,
def => 4,
} );
++$tests && is($lexed, q|lexer_test ( {
abc => 2,
def => 4,
} );|, 'Hashref multiline');
lexer_test
"test string",
$a,
$b
;
++$tests && is($lexed, q|lexer_test
"test string",
$a,
$b
;|, 'Normal multiline');
# FIXME a \n inside a block breaks line numbering
lexer_test {
print "1";
print "2";
print "3";
print "...";
};
++$tests && is($lexed, q|lexer_test {
print "1";
print "2";
print "3";
print "...";
};|, 'Block');
lexer_test 1 || 1;
++$tests && is($lexed, q/lexer_test 1 || 1;/, 'Or in statement');
lexer_test 1 && 1;
++$tests && is($lexed, q/lexer_test 1 && 1;/, 'And in statement');
lexer_test 1 |= 1;
++$tests && is($lexed, q/lexer_test 1 |= 1;/, 'Or equals in statement');
++$tests && is(__LINE__, 131, 'Line numbering (CHECK WHICH LINE THIS IS ON)');
done_testing $tests;
#100 / 0;
#!/usr/bin/perl
package Devel::Declare::Lexer::Factory::t;
use strict;
use warnings;
use Devel::Declare::Lexer qw/ test /;
use Devel::Declare::Lexer::Factory qw ( _stream );
use Devel::Declare::Lexer::Token::Raw;
use Test::More;
#BEGIN { $Devel::Declare::Lexer::DEBUG = 1; }
my $tests = 0;
BEGIN {
Devel::Declare::Lexer::lexed(test => sub {
my ($stream_r) = @_;
# Create a new stream from the old one (consumes declarator and whitespace)
my @stream = _stream($stream_r, [ new Devel::Declare::Lexer::Token::Raw ( value => <<EOF
1;
sub abc
{
my (\$a, \$b) = \@_;
return \$a * \$b;
}
EOF
) ]);
return \@stream;
});
}
my $test;
test "abc";
++$tests && is(abc(10,10), 100, 'Using raw token');
++$tests && is(__LINE__, 40, 'Line numbering (CHECK WHICH LINE THIS IS ON)');
done_testing $tests;
#100 / 0;
#!/usr/bin/perl
package Devel::Declare::Lexer::t;
use strict;
use warnings;
use Devel::Declare::Lexer qw/ :lexer_test /; # creates a lexer_test keyword and places lexed code into runtime $lexed
use Test::More;
#BEGIN { $Devel::Declare::Lexer::DEBUG = 1; }
my $tests = 0;
my $lexed;
lexer_test "A [%s] B [%s]", $answer, $question [Consent, Validate];
++$tests && is($lexed, q/lexer_test "A [%s] B [%s]", $answer, $question [Consent, Validate];/, 'With $question');
done_testing $tests;
#100 / 0;
t/deinterpolate.t view on Meta::CPAN
#!/usr/bin/perl
package Devel::Declare::Lexer::t;
use strict;
use warnings;
use Test::More;
use Data::Dumper;
use Devel::Declare::Lexer qw( test );
use Devel::Declare::Lexer::Tokens;
our $DEBUG = 0;
BEGIN {
$Devel::Declare::Lexer::DEBUG = $Devel::Declare::Lexer::t::DEBUG;
Devel::Declare::Lexer::lexed(test => sub {
my $stream_r = shift;
my @stream = @$stream_r;
my $string = $stream[4]->{value};
my @vars = $stream[4]->deinterpolate;
print STDERR Dumper \@vars if $DEBUG;
if(scalar @vars) {
push @stream, new Devel::Declare::Lexer::Token::Raw(
value => '; @testvars = (\'' . (join '\', \'', @vars) . '\');'
);
} else {
push @stream, new Devel::Declare::Lexer::Token::Raw(
value => '; @testvars = ();'
);
}
return \@stream;
});
}
my $a = "a";
our $shared = "shared";
my $ar = \$a;
my @b = ("b");
my %c = ("c" => "c");
my $tests = 0;
my @testvars;
test print "This is $a string\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$a', 'Captured $a');
test print "This is @b string\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '@b', 'Captured @b');
test print "This is $b[0] string\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$b[0]', 'Captured @b[0]');
test print "This is $c{c} string\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$c{c}', 'Captured $c{c}');
test print "This is \$a string\n";
++$tests && is(scalar @testvars, 0, 'Captured 0 variable');
test print "This is \\$a string\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$a', 'Captured $a');
test print "This is \\\$a string\n";
++$tests && is(scalar @testvars, 0, 'Captured 0 variable');
test print "This is \\\\$a string\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$a', 'Captured $a');
test print "This is \\\\$a string and a \\\\@b string\n";
++$tests && is(scalar @testvars, 2, 'Captured 2 variable');
++$tests && is($testvars[0], '$a', 'Captured $a');
++$tests && is($testvars[1], '@b', 'Captured @b');
test print "This is \\\\$a string and a \\\@b string\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$a', 'Captured $a');
test print "This is \$a string and a \\@b string\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '@b', 'Captured @b');
test print "I want to interpolate '$a' but not '\@b'\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$a', 'Captured $a');
test print "I want to interpolate '$$ar' but not '\@b'\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$$ar', 'Captured $$ar');
test print "I want to interpolate '$$ar$a' but not '\@b'\n";
++$tests && is(scalar @testvars, 2, 'Captured 2 variable');
++$tests && is($testvars[0], '$$ar', 'Captured $$ar');
++$tests && is($testvars[1], '$a', 'Captured $a');
test print "I want to interpolate '$$ar@b' but not '\@b'\n";
++$tests && is(scalar @testvars, 2, 'Captured 2 variable');
++$tests && is($testvars[0], '$$ar', 'Captured $$ar');
++$tests && is($testvars[1], '@b', 'Captured @b');
test print "I want to interpolate '$Devel::Declare::Lexer::t::shared' but not '\@b'\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$Devel::Declare::Lexer::t::shared', 'Captured $Devel::Declare::Lexer::t::shared');
test print "I want to interpolate '$Devel::Declare::Lexer::t::shared$$ar@b' but not '\$Devel::Declare::Lexer::t::shared\$\$ar\@b'\n";
++$tests && is(scalar @testvars, 3, 'Captured 3 variable');
++$tests && is($testvars[0], '$Devel::Declare::Lexer::t::shared', 'Captured $Devel::Declare::Lexer::t::shared');
++$tests && is($testvars[1], '$$ar', 'Captured $$ar');
++$tests && is($testvars[2], '@b', 'Captured @b');
test print "This is a %s format%s", "sprintf", "\n";
++$tests && is(scalar @testvars, 0, 'Captured 0 variable');
test print "$$: Perl special variable\n";
++$tests && is(scalar @testvars, 1, 'Captured 1 variable');
++$tests && is($testvars[0], '$$', 'Captured $$');
test print "Variable with comma $a, $a\n";
++$tests && is(scalar @testvars, 2, 'Captured 2 variable');
++$tests && is($testvars[0], '$a', 'Captured $a');
++$tests && is($testvars[1], '$a', 'Captured $a again');
done_testing($tests);
exit;
( run in 1.727 second using v1.01-cache-2.11-cpan-5a3173703d6 )