I've created an Object such as
my $hex = Hexagram->new();
and it has various methods:
top
bot
chinese
title
meaning
This object will be created numerous times and each time I need to gather and test information for each of the above methods.
I would like to do something like
foreach my $method ( qw/top bot chinese title meaning/ )
{
&gather_info($hex,$method);
}
and then have something like
sub gather_info {
my ($hex,$method) = #_;
print "What is the $method? ";
my $response = <STDIN>;
chomp $response;
$hex->${method}($reponse);
.... and other actions ....
}
But this doesn't work. Instead, for each method I seem to have to write out the basic code structure again and again which just seems plain wasteful.
I've also tried something where I try to pass a reference to the method call such as in
foreach my $ra ( [\$hex->top, "top"],
[\$hex->bot, "bot"],....)
{
my ($object_method, $name) = #{$ra};
&rgather_info($object_method, $name);
}
where
sub $gather_info {
my ($rhex, $name) = #_;
print "What is the $name?";
my $response = <STDIN>;
chomp $response;
&{$rhex}($response);
.... and other actions ....
}
But this time I get an error about
Not a CODE reference at <program name> line <line number>,....
Any suggestions on how I can do this?
According to perlobj method calls can be made using a string variable.
$object->$method( #args );
So your foreach loop should have worked fine. Or this one, which is much less wordy:
use strict;
use warnings;
my $hex = Hexagram->new();
gather_info( $hex, $_ )
for qw/top bot chinese title meaning/;
sub gather_info {
my ($hex, $method) = #_;
print "What is $method?\n";
my $response = <STDIN>;
chomp $response;
$hex->$method( $response );
}
Make sure you have strict and warnings enabled and try again. Update you post with errors, etc.
Related
I'm trying to mirror the website which having the files and folder to hash.
This one having example So I tried, the following
my $url = "http://localhost/mainfolder/";
my ($parent) = $url=~m/\/(\w+)\/?$/;
my %tree=(mainfolder=>[]);
folder_create($url);
sub folder_create
{
my $url = shift;
my $cont = get($url);
my ($child) = $url=~m/($parent.*)/;
$child=~s/\/?(\w+)\/?/{$1}/g;
while($cont=~m/(<tr.+?<\/tr>)/g)
{
my $line = $1;
if($line=~m/\[DIR\].*?href="([^"]*)"[^>]*>(.+?)<\/a>/)
{
my $sub =$1;
$sub=~s/\///;
print "$child\n\n";
push ( eval'#{$tree $child}',$sub);
}
}
}
use Data::Dumper;
print Dumper \%tree,"\n\n\n";
Update
Instead of messing with eval you should use the Data::Diver module
Because of the single quotes, you're trying to execute #{$hash$var} which isn't valid Perl.
If you wrote it as
push eval "\#{\$hash$var}", "somedata"
Then the eval would work, but it would evaluate to the contents of the array in hash element main, which is an empty list of values. That means your call would become
push( ( ), "somedata")
or just
push "somedata"
which is meaningless
This is a particularly unpleasant thing to want to do. Why do you think you need it?
I am pulling bitbucket repo list using Perl. The response from bitbucket will contain only 10 repositories and a marker for the next page where there will be another 10 repos and so on ... (they call it paging response)
So, I wrote a recursive subroutine which calls itself if the next page marker is present. This will continue until it reaches the last page.
Here is my code:
#!/usr/bin/perl
use warnings;
use strict;
use Data::Dumper;
use LWP::UserAgent;
use JSON;
my #array;
recursive("my_bitbucket_url");
foreach ( #array ) { print $_."\n"; }
sub recursive
{
my $url = $_[0];
### here goes my LWP::UserAgent code which connects to bitbucket and pulls back the response in a JSON as $response->decoded_content
### hence, removing this code for brevity
my $hash = decode_json $response->decoded_content;
#print Dumper ($hash);
foreach my $a ( #{$hash->{values}} )
{
push #array, $a->{links}->{self}->{href};
}
if ( defined $hash->{next})
{
print "Next page Exists \n";
print "Recursing with $hash->{next} \n";
recursive( $hash->{next} );
}
else
{
print "Last page reached. No more recursion \n"
}
}
Now, my code works fine and it lists all the repos.
Question:
I am not sure about the way I have used the variable my #array; above. I have defined it outside the subroutine, However, I am accessing it directly from the subroutine. Somehow, I feel this is not right.
So, how to append to an array using a recursive subroutine in such cases. Does my code obey Perl ethics or is it something really absurd (yet correct because it works) ?
UPDATE
After following suggestions from #ikegami, #Sobrique and #Hynek -Pichi- Vychodil, I have come with below code which uses while loop and avoids recusrsion.
Here is my thought process:
Define an array #array.
Call the subroutine call_url with initial bitbucket URL and save the response in $hash
Check the $hash for the next page marker
If next page marker exists, then push the elements to #array and call call_url with the new marker. This will be done with the while loop.
If the next page marker does NOT exists, then push the elements to #array. Period.
Print #array content.
And here is my code:
my #array;
my $hash = call_url("my_bitbucket_url ");
if (defined $hash->{next})
{
while (defined $hash->{next})
{
foreach my $a ( #{$hash->{values}} )
{
push #array, $a->{links}->{self}->{href};
}
$hash = call_url($hash->{next});
}
}
foreach my $a ( #{$hash->{values}} )
{
push #array, $a->{links}->{self}->{href};
}
foreach (#array) { print $_."\n"; }
sub call_url
{
### here goes my LWP::UserAgent code which connects to bitbucket and pulls back the response in a JSON as $response->decoded_content
### hence, removing this code for brevity
my $hash = decode_json $response->decoded_content;
#print Dumper ($hash);
return $hash;
}
Would definitely like to hear whether this looks OK or is there still a room for improvement.
Using global variables to return values demonstrates high coupling, something to be avoided.
You're asking if the following is acceptable:
my $sum;
sum(4, 5);
print("$sum\n");
sub sum {
my ($x, $y) = #_;
$sum = $x + $y;
}
The fact that the sub is recursive is completely irrelevant; it just makes your example larger.
Problem fixed:
sub recursive
{
my $url = $_[0];
my #array;
my $hash = ...;
foreach my $a ( #{$hash->{values}} )
{
push #array, $a->{links}->{self}->{href};
}
if ( defined $hash->{next})
{
print "Next page Exists \n";
print "Recursing with $hash->{next} \n";
push #array, recursive( $hash->{next} );
}
else
{
print "Last page reached. No more recursion \n"
}
return #array;
}
{
my #array = recursive("my_bitbucket_url");
foreach ( #array ) { print $_."\n"; }
}
Recursion removed:
sub recursive
{
my $url = $_[0];
my #array;
while (defined($url)) {
my $hash = ...;
foreach my $a ( #{$hash->{values}} )
{
push #array, $a->{links}->{self}->{href};
}
$url = $hash->{next};
if ( defined $url)
{
print "Next page Exists \n";
print "Recursing with $url\n";
}
else
{
print "Last page reached. No more recursion \n"
}
}
return #array;
}
{
my #array = recursive("my_bitbucket_url");
foreach ( #array ) { print $_."\n"; }
}
Clean up of the latest code you posted:
my $url = "my_bitbucket_url";
my #array;
while ($url) {
my $hash = call_url($url);
for my $value ( #{ $hash->{values} } ) {
push #array, $value->{links}{self}{href};
}
$url = $hash->{next};
}
print("$_\n") for #array;
Yes, using a global variable is bad habit even it is lexical scoped variable.
Each recursive code can be rewritten into its imperative loop version and vice versa. It is because all of this is implemented on CPU which doesn't know anything about recursion at all. Thre are only jumps. All calls and returns are just jumps with some stack manipulation so you can rewrite your recursion algorithm into loop. If it is not obvious and simple as in this case you can even emulate stack and behaviour as it is done in your favourite language interpreter or compiler. In this case it's very simple:
my #array = with_loop("my_bitbucket_url");
foreach ( #array ) { print $_."\n"; }
sub with_loop
{
my $url = $_[0];
my #array;
while(1)
{
### here goes my LWP::UserAgent code which connects to bitbucket and
### pulls back the response in a JSON as $response->decoded_content
### hence, removing this code for brevity
my $hash = decode_json $response->decoded_content;
#print Dumper ($hash);
foreach my $a ( #{$hash->{values}} )
{
push #array, $a->{links}->{self}->{href};
}
unless ( defined $hash->{next})
{
print "Last page reached. No more recursion \n";
last
};
print "Next page Exists \n";
print "Recursing with $hash->{next} \n";
$url = $hash->{next};
};
return #array;
}
But when you would like to stick with recursion you can but it is a little bit more tricky. First of all, there is not tail call optimization so you don't have to try write tail call code as your original version does. So you can do this:
my #array = recursion("my_bitbucket_url");
foreach ( #array ) { print $_."\n"; }
sub recursion
{
my $url = $_[0];
### here goes my LWP::UserAgent code which connects to bitbucket and
### pulls back the response in a JSON as $response->decoded_content
### hence, removing this code for brevity
my $hash = decode_json $response->decoded_content;
#print Dumper ($hash);
# this map version is same as foreach with push but more perlish
my #array = map $_->{links}->{self}->{href}, #{$hash->{values}};
if (defined $hash->{next})
{
print "Next page Exists \n";
print "Recursing with $hash->{next} \n";
push #array, recursive( $hash->{next} );
}
else
{
print "Last page reached. No more recursion \n"
}
return #array;
}
But this version is not very efficient so there is way how to write tail call recursive version in perl which is a little bit tricky.
my #array = tail_recursive("my_bitbucket_url");
foreach ( #array ) { print $_."\n"; }
sub tail_recursive
{
my $url = $_[0];
my #array;
return tail_recursive_inner($url, \#array);
# url is mutable parameter
}
sub tail_recursive_inner
{
my $url = $_[0];
my $array = $_[1];
# $array is reference to accumulator #array
# from tail_recursive function
### here goes my LWP::UserAgent code which connects to bitbucket and
### pulls back the response in a JSON as $response->decoded_content
### hence, removing this code for brevity
my $hash = decode_json $response->decoded_content;
#print Dumper ($hash);
foreach my $a ( #{$hash->{values}} )
{
push #$array, $a->{links}->{self}->{href};
}
if (defined $hash->{next})
{
print "Next page Exists \n";
print "Recursing with $hash->{next} \n";
# first parameter is mutable so its OK to assign
$_[0] = $hash->{next};
goto &tail_recursive_inner;
}
else
{
print "Last page reached. No more recursion \n"
}
return #$array;
}
And if you are interested in some real perl trickery
print $_."\n" for tricky_tail_recursion("my_bitbucket_url");
sub tricky_tail_recursion {
my $url = shift;
### here goes my LWP::UserAgent code which connects to bitbucket and
### pulls back the response in a JSON as $response->decoded_content
### hence, removing this code for brevity
my $hash = decode_json $response->decoded_content;
#print Dumper ($hash);
push #_, $_->{links}->{self}->{href} for #{$hash->{values}};
if (defined $hash->{next}) {
print "Next page Exists \n";
print "Recursing with $hash->{next} \n";
unshift #_, $hash->{next};
goto &tricky_tail_recursion;
} else {
print "Last page reached. No more recursion \n"
};
return #_;
}
See also: LWP::UserAgent docs.
A variable defined outside any closures is available to the whole program. It works fine, there's nothing to worry about. Some might call it 'bad style' in certain cases (mostly around program length and action at distance) but that's not a hard constraint.
I'm not sure I necessarily see the advantage of recursion here though - your problem doesn't seem to warrant it. That's not a problem per-se, but it can be a little confusing for future maintenance programmers ;).
I'd be thinking something along the lines of (non recursive):
my $url = "my_bitbucket_url";
while ( defined $url ) {
##LWP Stuff;
my $hash = decode_json $response->decoded_content;
foreach my $element ( #{ $hash->{values} } ) {
print join( "\n", #{ $element->{links}->{self}->{href} } ), "\n";
}
$url = $hash->{next}; #undef if it doesn't exist, so loop breaks.
}
I am trying to use MooseX::Method::Signatures and MooseX::Declare in an application, my need is to inject custom code at the beginning of each method at compile time not at run time:
instead of this:
use MooseX::Declare;
method check ($value) {
$return $value;
}
I want to inject a code at the beginning of each method at compile time to be like that:
method check ($value) {
my ($value) = $self->validate($value);
$return $value;
}
now I want the code
my ($value) = $self->validate($value);
to be injected automatically at the beginning of all methods in the package using the MooseX::Decalre module at compile time and not at run time, I mean not using the Moose method modifiers before, after, around etc.
This needs a modification of these module but I need someone to tell me where to start.
I was able to modify the module Method::Signatures::Simple to do this exactly and emailed the author for the modification but did not get a reply. The reason I can not use this even with modification because it does not support type checking and defaults like MooseX::Declare.
The modified version of the module Method::Signatures::Simple below for reference and I use it as follows:
use Method::Signatures::Simple (method => 'method,action', function =>
'function', invocant=>'$this', 'inject'=>'my ($me) = $this->me;');
now in all methods, I get the code my ($me) = $this->me; injected and I just can use it like that:
method check ($value) {
say $me
}
Here is the modified Method::Signatures::Simple module.
package Method::Signatures::Simple;
{
$Method::Signatures::Simple::VERSION = '1.07';
}
use warnings;
use strict;
=head1 NAME
Method::Signatures::Simple - Basic method declarations with signatures, without source filters
=head1 VERSION
version 1.07
=cut
use base 'Devel::Declare::MethodInstaller::Simple';
our $inject_code;
sub import {
my $class = shift;
my %opts = #_;
$opts{into} ||= caller;
my $meth = delete $opts{name} || delete $opts{method};
my $func = delete $opts{function};
my $invocant = delete $opts{invocant} || '$self';
$inject_code = delete $opts{inject};
$inject_code .= ";" if ($inject_code && $inject_code !~ /\;$/);
# if no options are provided at all, then we supply defaults
unless (defined $meth || defined $func) {
$meth = 'method';
$func = 'func';
}
my #meth = split /\s*\,+\s*/, $meth;
# we only install keywords that are requested
foreach $meth (#meth) {
if (defined $meth) {
$class->install_methodhandler(
name => $meth,
invocant => $invocant,
%opts,
);
}
}
if (defined $func) {
$class->install_methodhandler(
name => $func,
%opts,
invocant => undef,
);
}
}
sub strip_proto {
my $self = shift;
my ($proto) = $self->SUPER::strip_proto()
or return '';
# we strip comments and newlines here, and stash the number of newlines.
# we will re-inject the newlines in strip_attrs(), because DD does not
# like it when you inject them into the following code block. it does not
# object to tacking on newlines to the code attribute spec though.
# (see the call to inject_if_block() in DD::MethodInstaller::Simple->parser)
$proto =~ s/\s*#.*$//mg;
$self->{__nls} = $proto =~ s/[\r\n]//g;
$proto;
}
sub strip_attrs {
my $self = shift;
my ($attrs) = $self->SUPER::strip_attrs();
$attrs ||= '';
$attrs .= $/ x $self->{__nls} if $self->{__nls};
$attrs;
}
sub parse_proto {
my $self = shift;
my ($proto) = #_;
$proto ||= '';
$proto =~ s/\s*#.*$//mg;
$proto =~ s/^\s+//mg;
$proto =~ s/\s+$//mg;
$proto =~ s/[\r\n]//g;
my $invocant = $self->{invocant};
$invocant = $1 if $proto =~ s{(\$\w+)\s*:\s*}{};
my $inject = '';
$inject .= "my ${invocant} = shift;" if $invocant;
$inject .= "my ($proto) = \#_;" if defined $proto and length $proto;
$inject .= "$inject_code" if $inject_code;
$inject .= '();'; # fix for empty method body
return $inject;
}
Moops and Kavorka provide a syntax almost compatible with MooseX::Declare and MooseX::Method::Signatures, and are designed to be very extensible (even from within!) via traits. I'll draw your attention to the following section of documentation for MooseX::Declare:
Warning: MooseX::Declare is based on Devel::Declare, a giant bag of crack originally implemented by mst with the goal of upsetting the perl core developers so much by its very existence that they implemented proper keyword handling in the core.
[...]
If you want to use declarative syntax in new code, please for the love of kittens get yourself a recent perl and look at Moops instead.
MooseX::Declare itself is not very easy to extend. I know. I've tried.
So bearing all that in mind, and also because I wrote Moops, I'll use that for the example. Here we define a role Kavorka::TraitFor::Sub::ProvidesMe which is will inject a little bit of code into a method. We then apply that role to a method using does ProvideMe.
package main;
use Moops;
role Kavorka::TraitFor::Sub::ProvideMe
{
around inject_prelude (#_)
{
my $prelude = $self->$next(#_);
$prelude .= 'my ($me) = $self->me;();';
return $prelude;
}
}
class MyClass
{
method me () { "tobyink" }
method example () does ProvideMe
{
# This gets injected: my ($me) = $self->me;
return $me;
}
}
my $obj = MyClass->new;
say $obj->example; ## says "tobyink"
So what I am trying to do with the following code is push a string, let's say "this string" onto the end of each key in a hash. I'm completely stumped on how to do this. Here's my code:
use warnings;
use strict;
use File::Find;
my #name;
my $filename;
my $line;
my #severity = ();
my #files;
my #info = ();
my $key;
my %hoa;
my $xmlfile;
my $comment;
my #comments;
open( OUTPUT, "> $ARGV[0]" );
my $dir = 'c:/programs/TEST/Test';
while ( defined( $input = glob( $dir . "\\*.txt" ) ) ) {
open( INPUT, "< $input" );
while (<INPUT>) {
chomp;
if (/File/) {
my #line = split /:/;
$key = $line[1];
push #{ $hoa{$key} }, "Filename\n";
}
if ( /XML/ ... /File/ ) {
$xmlfile = $1;
push #{ $hoa{$key} }, "XML file is $xmlfile\n";
}
if (/Important/) {
push #{ $hoa{$key} }, "Severity is $_\n";
}
if (/^\D/) {
next if /Important/;
push #{ $hoa{$key} }, "Given comment is $_\n";
}
push #{ $hoa{$key} }, "this string\n";
}
}
foreach my $k ( keys %hoa ) {
my #list = #{ $hoa{$k} };
foreach my $l (#list) {
print OUTPUT $l, "\n";
}
}
}
close INPUT;
close OUTPUT;
Where I have "this string" is where I was trying to push that string onto the end of the array. However, what ended up happening was that it ended up printing "this string" three times, and not at the end of every key like I wanted. When I tried to put it outside the while() loop, it said that the value of $key was not initialized. So please, any help? And if you need any clarification on what I'm asking, just let me know. Thank you!
No offence, but there are so many issues in this code I don't even know where to start...
First, the 'initialization block' (all these my $something; my #somethings lines at the beginning of this script) is not required in Perl. In fact, it's not just 'redundant' - it's actually confusing: I had to move my focus back and forth every time I encountered a new variable just to check its type. Besides, even with all this $input var is still not declared as local; it's either missing in comments, or the code given has omissions.
Second, why do you declare your intention to use File::Find (good) - but then do not use it at all? It could greatly simplify all this while(glob) { while(<FH>) { ... } } routine.
Third, I'm not sure why you assign something to $key only when the line read is matched by /File/ - but then use its value as a key in all the other cases. Is this an attempt to read the file organized in sections? Then it can be done a bit more simple, either by slurp/splitting or localizing $/ variable...
Anyway, the point is that if the first line of the file scanned is not matched by /File/, the previous (i.e., from the previous file!) value is used - and I'm not quite sure that it's intended. And if the very first line of the first file is not /File/-matched, then an empty string is used as a key - again, it smells like a bug...
Could you please describe your task in more details? Give some test input/output results, perhaps... It'd be great to proceed in short tasks, organizing your code in process.
Your program is ill-conceived and breaks a lot of good practice rules. Rather than enumerate them all, here is an equivalent program with a better structure.
I wonder if you are aware that all of the if statements will be tested and possibly executed? Perhaps you need to make use of elsif?
Aside from the possibility that $key is undefined when it is used, you are also setting $xmlfile to $1 which will never be defined as there are no captures in any of your regular expressions.
It is impossible to tell from your code what you are trying to do, so we can help you only if you show us your output, input and say how to derive one from the other.
use strict;
use warnings;
use File::Find;
my ($outfile) = #ARGV;
my $dir = 'c:/programs/TEST/Test';
my %hoa;
my $key;
while (my $input = glob "$dir/*.txt") {
open my $in, '<', $input or die $!;
while (<$in>) {
chomp;
if (/File/) {
my $key = (split /:/)[1];
push #{ $hoa{$key} }, "Filename\n";
}
if (/XML/ ... /File/) {
my $xmlfile = $1;
push #{ $hoa{$key} }, "XML file is $xmlfile\n";
}
if (/Important/) {
push #{ $hoa{$key} }, "Severity is $_\n";
}
if (/^\D/) {
next if /Important/;
push #{ $hoa{$key} }, "Given comment is $_\n";
}
push #{ $hoa{$key} }, "this string\n";
}
close $in;
}
open my $out, '>', $outfile or die $!;
foreach my $k (keys %hoa) {
foreach my $l (#{ $hoa{$k} }) {
print $out $l, "\n";
}
}
close $out;
I suspect based on your code, that the line where $key is set is not called each time through the loop, and that you do not trigger any of the other if statements.
This would append "this string" to the end of the array. Based on that you are getting 3 of the "this strings" at the end of the array, I would suspect that two lines do not go through the if (/FILE/) or any of the other if statements. This would leave the $key value the same and at the end, you would append "this string" to the array, using whatever the last value of $key was when it was set.
This will append the string "this string" to every element of the hash %hoa, which elements are array refs:
for (values(%hoa)) { push #{$_}, "this string"; }
Put that outside your while loop, and you'll print "this string" at the end of each element of %hoa.
It will autovivify array refs where it finds undefined elements. It will also choke if it cannot dereference an element as an array, and will manipulate arrays by symbolic reference if it finds a simple scalar and is not running under strict:
my %autoviv = ( a => ['foo'], b => undef );
push #$_, "PUSH" for values %autoviv; # ( a => ['foo', 'PUSH'], b => ['PUSH'] )
my %fatal = ( a => {} );
push #$_, "PUSH" for values %fatal; # FATAL: "Not an ARRAY reference at..."
my %dangerous = (a => "foo");
push #$_, "PUSH" for values %dangerous; # Yikes! #foo is now ("PUSH")
use strict;
my %kablam = (a => "foo");
push #$_, "PUSH" for values %kablam; # "Can't use string ("foo") as an ARRAY ref ..."
As I understand it, traverse the hash with a map command to modify its keys. An example:
EDIT: I've edited because I realised that the map command can be assigned to the same hash. No need to create a new one.
#!/usr/bin/perl
use warnings;
use strict;
use Data::Dumper;
my %hash = qw|
key1 value1
key2 value2
key3 value3
|;
my %hash = map { $_ . "this string" => $hash{ $_ } } keys %hash;
print Dump \%hash;
Run it like:
perl script.pl
With following output:
$VAR1 = {
'key3this string' => 'value3',
'key2this string' => 'value2',
'key1this string' => 'value1'
};
I seek a perl module to convert CppUnit output to TAP format. I want to use the prove command afterwards to run and check the tests.
Recently I was doing some converting from junit xml (not to TAP format though).
It was very easy to do by using XML::Twig module.
You code should look like this:
use XML::Twig;
my %hash;
my $twig = XML::Twig->new(
twig_handlers => {
testcase => sub { # this gets called per each testcase in XML
my ($t, $e) = #_;
my $testcase = $e->att("name");
my $error = $e->field("error") || $e->field("failure");
my $ok = defined $error ? "not ok" : "ok";
# you may want to collect
# testcase name, result, error message, etc into hash
$hash{$testcase}{result} = $ok;
$hash{$testcase}{error} = $error;
# ...
}
}
);
$twig->parsefile("test.xml");
$twig->purge();
# Now XML processing is done, print hash out in TAP format:
print "1..", scalar(keys(%hash)), "\n";
foreach my $testcase (keys %hash) {
# print out testcase result using info from hash
# don't forget to add leading space for errors
# ...
}
This should be relatively easy to polish into working state