If you have a question on how to do something in Perl, or you need a Perl solution to an actual real-life problem, or you're unsure why something you've tried just isn't working... then this section is the place to ask.

However, you might consider asking in the chatterbox first (if you're a registered user). The response time tends to be quicker, and if it turns out that the problem/solutions are too much for the cb to handle, the kind monks will be sure to direct you here.

Post a new question!

User Questions
Creating a Multi Level Hash from CSV
2 direct replies — Read more / Contribute
by workInProgress12
on May 12, 2021 at 15:11
    New to perl here and have been trying to figure this one out for a couple days now. I think I need nested forall loops or something along those lines. The task that needs to be done is to assign the columns to a multi level hash. So if my csv file was something like something below. Important to note that there are repeated values, which is the case for the provided sample output, (ie info 01 = info11, info02 = info12, etc.), but this is not always the case.
    header1,header2,header3.... info01,info02,info03... info11,info12,info13.. : : :
    The hash would look like (with the appropriate brackets)
    $VAR1 = { info01 => { info02 => { info03 => { info02 => { info12 => { info13 => {
    What I have right now:
    # MODULES use strict; use warnings; use Pod::Usage; use Data::Dumper; use Getopt::Long; use File::Basename; use Cwd 'abs_path'; use Data::Dumper qw(Dumper); use Text::CSV; my $csv = Text::CSV->new({ binary => 1, auto_diag => 1, sep_char => ',' }); my @columns; open(my $input, '<:utf8',"input.csv") or die; while (<$input>){ $csv->parse($_) or die "parse() failed: "; my @data = $csv->getline($input); for my $i (0..$#data) { # push @{$columns[$i]}, $data[$i]; push @{$columns[$i]}, $data[$i]; } } close $input; my %hash = map {shift @$_ => $_} @columns; use Data::Dumper; print Dumper(\%hash);
    This is giving me my values all in one line and not how is required
do $n exist in grep?
5 direct replies — Read more / Contribute
by misterperl
on May 12, 2021 at 10:32
    are the $n vars available somehow? in a statement like
    grep /^..(A|B)./,@a;
    Is $1 captured somewhere? It would be nice if $1 became an arrayref in this case?

    BTW it seems inconsistent that the parens in this statement might be moot. Seems odd to have syntax there that is meaningless in this context. If $1 was returned as an arrayref, it would make good sense, vis-a-vis over-loading et all?

Designing multiple related modules
3 direct replies — Read more / Contribute
by Bod
on May 12, 2021 at 08:06

    Not strictly a Perl question although the solution will be implemented in Perl and the modules will probably appear on CPAN...

    I am writing three, perhaps more, related modules which will have the same basic methods. The three modules will post content to different social media sites. I want to be able to use them something like this:

    my $social; if ($network eq 'Facebook') { $social = Bod::Social::Facebook->new( ... ); } if ($network eq 'Twitter') { $social = Bod::Social::Twitter->new( ... ); } if ($network eq 'LinkedIn') { $social = Bod::Social::LinkedIn->new( ... ); } unless ($social) { # Handle invalid network; } # Post text content to whichever network has been selected without car +ing which $social->post("Some test text"); # Post text and image content my $image_handle = $social->upload("images/test.jpg"); $social->post("Test text with image", $image_handle);
    There are at least three four options of how to implement this, probably more. I am looking for some advice on which way I should choose.

    1 - Three separate module
    Simply write three modules with similar names as in the code above. Each module has methods with the same names and similar new method. All social media platforms use OAuth2 so new can be largely the same.

    2 - Three modules that all inherit from one class
    Have a Bod::Social module that defines the methods. Then have modules as in the code above that inherit from Bod::Social and implement the methods. A bit like what I understand an interface to be in Java1. I don't see any advantage in this option in Perl over option 1 but there are certainly modules on CPAN that do this. Either there is good reason or they are written by people coming from stricter OOP languages.

    3 - Have a single method and Service Providers
    Have a single module that the code uses. In the new method, specify a Service Provider that is different for each social network. Each service provider implements the platform specific calls needed for interacting with the network. LWP::Authen::OAuth2 is implemented this way and it seems to work reasonably well but, again, I don't understand the advantages and disadvantages of this approach. Like this:

    my $social; if ($network eq 'Facebook') { $social = Bod::Social->new( service_provider => 'Facebook', ... , ); } if ($network eq 'Twitter') { $social = Bod::Social->new( service_provider => 'Twitter', ... , ); } if ($network eq 'LinkedIn') { $social = Bod::Social->new( service_provider => 'LinkedIn', ... , ); }

    4 - Use a Factory Class
    Use a Factory Class as we discussed here -> Factory classes in Perl
    As these modules will always run in the same environment this strikes me as overkill.


    I don't see there being a need to add new networks very frequently but it is quite possible that others will need adding. Which approach would you take or would you use a different solution I haven't considered? Why would you do it that way?

    This more general than just this application. Since writing Business::Stripe::WebCheckout I have decided that it would be useful if there was also Business::PayPal::WebCheckout that behaves exactly the same. Therefore the end user's code only has to call a different constructor and everything else gets called the same for multiple payment gateways. I am sure there will be more requirements for multiple related module.

    1 I'm not a Java programmer and only use it when I need to create simple Android apps.

    Edit 1: - Added option 4

    Edit 2: - Added reference to Business::Stripe::WebCheckout and corrected spelling errors.

weird case of memory corruption?
3 direct replies — Read more / Contribute
by perltux
on May 11, 2021 at 23:03
    Hi, I have come across a very weird problem while trying to use Tk::ProgressBar.
    Basically when running the following code, the output of the Label() after creating the ProgressBar seems to contain random bytes of the source code of the script itself rather than the value of the variable.

    here is the example script:

    #!/usr/bin/perl use strict; use warnings; use Tk; use Tk::ProgressBar; my %pid=(ex1=>{as=>'temp', val=>'-21.5'}); my $mw=MainWindow->new(); my $tmpbar=$mw->Frame()->pack( -padx=>30 ); PBar( \$tmpbar, \$pid{ex1}{val}, '-30', '70' )->pack(); $tmpbar->Label( -textvariable => \$pid{ex1}{val} )->pack(); $tmpbar->Label( -text => "$pid{ex1}{as}" )->pack(); print STDOUT "val Labels: $pid{ex1}{val}\n"; MainLoop; sub PBar { my($frame, $val, $min, $max)=@_; print STDOUT "val PBar1: $$val\n"; my $pbar=$$frame->ProgressBar( -anchor=>'s', -width=>40, -length=>500, -blocks=>100, -gap=>1, -resolution=>0.5, -variable=>$val, -from=>$min, -to=>$max ); print STDOUT "val PBar2: $$val\n"; return $pbar; }
    when running this script you will see that the Label under the vertical ProgressBar instead of containing the value of $pid{ex1}{val}, prints out three random bytes that appear to be from the source of the script itself.

    What is happening here? Memory corruption? ::confused::

    Also (this is my second question), why does ProgressBar modify the value of $pid{ex1}{val} rather than just reading it?
Perl Tk canvases / abuse...
2 direct replies — Read more / Contribute
by Montain_Gman
on May 11, 2021 at 17:39

    So I have found using perl canvases to debug problems; and visualize things in my field can be quite easy and fast to do. Anyway what I've found is that if I do more than say 400x400 pixels worth of stuff on a canvas, it tends to bog down; and basically it will hang.

    If i stay at say 200x200; the canvas behaves fast and I just don't get this problem. I have found (maybe superstitiously); that using idletasks to break things up helps, but I'm not sure exactly what is going on. I suspect without it, I am flooding some queue inside TK. There also seems to be a relationship with the hang and the amount of memory I am using.

    Anyway I can't post my 'real' script, as it's tied to real work. Essentially i need to simulate a legacy graphics system, and I'm using perl/tk to test things out before we do the real work on the target. My real resolution I need to hit is just over 400x400; but if i operate it that way, I can generally only get 1-2 images displayed before it will hang. (200x200; runs nice) So i created this little script to just see if i could get the same thing to happen to post here, and it generally has the same issue. If you run this, you can then use the mouse (press and hold, move, and release) to draw lines. Hitting go will redraw the back ground. If you do those things 2-3 times; especially if you make the resolution a bit higher; it is locking up for me.

    Can anyone enlighten me on what can be done to avoid this, or what is happening under the hood? Is there an easier way to just do straight pixel level screen outputs? (image magic ? I tried getting that to work but had issues on my work machine...) So would rather just stick with TK because it is very lightweight to support. (easy to install / support; anyone with perl 5.8 already has it too...)

    Thanks. ONE last thing; in reviewing this; I found I am not clearing TAGS array. So that will keep eating more memory. But even if you do @TAGS =(); if you run the script enough; you'll still see the same thing happening. So that seems to be a clue; that it's a memory thing...

    use Tk; my @TAGS; my $canvas_width = 600; my $canvas_height = 600; my $mw = new MainWindow; my $top = $mw->Frame()->pack(-side=>'top'); $canvas=$top->Canvas( -width=>$canvas_width, -height=>$canvas_height, )->pack(-side=>'left'); my $size = 410; my $entry = $top->Entry(-textvariable=>\$size)->pack(-side=>'top'); my $button = $top->Button(-text=>"go",-command=>\&go)->pack( -side=>'top'); $mw->Tk::bind('<MouseWheel>', [\&wheel,Ev('D')]); $canvas->Tk::bind( "<Button>", [\&button_press,Ev('x'),Ev('y')]); $canvas->Tk::bind( "<ButtonRelease>", [\&button_release,Ev('x'),Ev('y')]); $canvas->Tk::bind( "<Motion>", [\&motion,Ev('x'),Ev('y')]); $mw->Tk::bind('<KeyPress>', [\&key,Ev('k')]); my $start_x; my $start_y; my $start_draw = 0; $mw->after(100,\&go); MainLoop(); #################################################################### sub button_press{ my ($dontknow,$x1,$y1) = @_; $start_draw = 1; $start_x = $x1; $start_y = $y1; } #################################################################### sub button_release{ my ($dontknow,$x1,$y1) = @_; if($start_draw){ $start_draw = 0; $canvas->createLine($start_x,$start_y,$x1,$y1, -width=>2,-fill=>'white'); } } #################################################################### sub motion{ my ($dontknow,$x1,$y1) = @_; } #################################################################### sub key{ my ($na,$key) = @_; print "$key\n"; } #################################################################### sub wheel{ my ($dontknow,$clicks) = @_; } #################################################################### sub erase{ for my $i (0..$#TAGS){ $canvas->delete($TAGS[$i]); if($i%($size*5)==0){ $mw->idletasks(); } } } #################################################################### sub go{ my @USE; &erase(); for my $i (0..$size-1){ for my $j (0..$size-1){ my $a = ($i%20) > 9; my $b = ($j%20) > 9; my $c; if($a^$b){ $c = sprintf("#%02X0000",$i%0xFF); } else { $c = sprintf("#00%02X00",$j%0xFF); } $USE[$i][$j]=$c; } } my $ps = $canvas_width/$size; for my $i (0..$#USE){ for my $j (0..$#{$USE[$i]}){ my $c = $USE[$i][$j]; my $tag = $canvas->createRectangle( $i*$ps,$j*$ps, $i*$ps+$ps,$j*$ps+$ps, -fill=>$c,-outline=>$c); push(@TAGS,$tag); } if($i%5==0){ $mw->idletasks(); } } $center_x = $canvas_width/2; $center_y = $canvas_height/2; $x_tag1 = $canvas->createLine( $center_x-10, $center_y-10, $center_x+10, $center_y+10, -width=>2,-fill=>'red'); $x_tag2 = $canvas->createLine( $center_x-10, $center_y+10, $center_x+10, $center_y-10, -width=>2,-fill=>'red'); # $mw->after(3000,\&go); }
Net::OpenSSH pass command
1 direct reply — Read more / Contribute
by touriste75
on May 11, 2021 at 13:42
    Hi, I try to use the module Net::OpenSSH with a Cisco to make simple test. I wish to execute 3 commands, without saving the result. The comman number 4 must capture the result. I use the system command for the 3 first and capture for the command 4. Unfortunatly, the command system seems to make problem.
    use Net::OpenSSH; my $host = '192.168.109.10'; my $user = 'admin'; my $password = 'admin'; my $port = '22'; my $ssh = Net::OpenSSH->new( host =>$host, user => $user, port => $port, password => $password); $ssh->error and die "Couldn't establish SSH connection: ". $ssh->error +; my $fichier_dst = "$host\.txt"; open (FH_OUT, '>', '/home/alexandre/Python_script/CISCO/' . $fichier_d +st);; my $cmd1 = 'conf t'; my $cmd2 = 'hostname TOTO'; my $cmd3 = 'exit'; $ssh->system("$cmd1"); $ssh->system("$cmd2"); $ssh->system("$cmd3"); my $cmd4 = 'sh run \| i hostname'; my ($out, $err) = $ssh->capture2("$cmd4"); $ssh->error and die "remote find command failed: " . $ssh->error; print "$out\n"; print FH_OUT $out; close(FH_OUT);

    Here the resultat.
    Seems to make two connexions and blocked with password

    If I use only the command capture, no problem of connexion.

    **************************************************************************
    * IOSv is strictly limited to use for evaluation, demonstration and IOS  *
    * education. IOSv is provided as-is and is not supported by Cisco's      *
    * Technical Advisory Center. Any use or disclosure, in whole or in part, *
    * of the IOSv Software or Documentation to any third party for any       *
    * purposes is expressly prohibited except as otherwise authorized by     *
    * Cisco in writing.                                                      *
    **************************************************************************
    Enter configuration commands, one per line.  End with CNTL/Z.Connection to 192.168.109.10 closed by remote host.
    
    **************************************************************************
    * IOSv is strictly limited to use for evaluation, demonstration and IOS  *
    * education. IOSv is provided as-is and is not supported by Cisco's      *
    * Technical Advisory Center. Any use or disclosure, in whole or in part, *
    * of the IOSv Software or Documentation to any third party for any       *
    * purposes is expressly prohibited except as otherwise authorized by     *
    * Cisco in writing.                                                      *
    **************************************************************************Password: 
    
    

    Thanks for your help.

Brackets in LWP Post
3 direct replies — Read more / Contribute
by Bod
on May 11, 2021 at 13:23

    A while ago I asked about Data::Dumper output which was silly error on my part that was obscuring what was really going on!

    The real problem is that LinkedIn is generating an error when I attempt to post. The error is: Illegal character VCHAR='(' So, instead of struggling with LWP::Authen::OAuth2, I thought I'd write my own module using LWP::Authen::OAuth2 to do the authentication and my own method to post to LinkedIn.

    But I still get the same problem. I have tried debugging all the variables I use and these are all as expected.
    This is the method I have to post to LinkedIn

    sub post { my ($self, $text) = @_; my $ua = $self->{'auth'}->user_agent; my $token = $self->{'auth'}->access_token; my $header = { 'Authorization:' => 'Bearer ' . $token->{'access_t +oken'}, 'X-Restli-Protocol-Version:' => '2.0.0', 'Content-type:' => 'text/json', }; my $user = $self->get_id; my $json = { 'owner' => "urn:li:person:$user", 'text' => { 'text' => $text, }, }; $ua->default_header('Content-type' => 'text/json'); return $ua->post( $self->{'auth'}->api_url_base . 'shares', Content => encode_json($json), $header, ); }

    First off we get the underlaying User Agent from $self->{'auth'}. This is an instance of LWP::Authen::OAuth2 which has been authorised. I have checked that authorisation is happening correctly by calling the me endpoint which returns the authenticated user. The underlaying User Agent is an instance of LWP::UserAgent.
    Next we get the user string which again I have checked to ensure it is correct - it is!

    We have to call $ua->default_header('Content-type' => 'text/json'); as, for some reason, it doesn't set in $header earlier.

    The call to $ua->post is going to the right place and sending the right data. The JSON payload might be a bit light to work as I have stripped it down to the bare minimum for testing. However, that would almost certainly produce a different error. When I call the method:

    my $post = $linkedin->post("Some test text to post"); print Dumper $post;
    I get a long JSON output back from LinkedIn. Here is the bit I think it is complaining about...
    '_request' => bless( { '_content' => '{"owner":"urn:l +i:person:GKiAGefMOA","text":{"text":"Some test text to post"}}', '_uri' => bless( do{\(my $o = +'https://api.linkedin.com/v2/shares')}, 'URI::https' ), '_headers' => bless( { 'user-a +gent' => 'libwww-perl/6.49', 'hash(0 +x29bc430)' => undef, 'conten +t-type' => 'text/json', 'conten +t-length' => 77, '::std_ +case' => { + 'hash(0x29bc430)' => 'HASH(0x29bc430)', + 'if-ssl-cert-subject' => 'If-SSL-Cert-Subject' + } }, 'HTTP: +:Headers' ), '_method' => 'POST', '_uri_canonical' => $VAR1->{'_ +request'}{'_uri'} }, 'HTTP::Request' )
    I do not understand where ::std_case is coming from or why it contains un expanded hash references. Is this a bug in LWP perhaps?

    Any ideas on how I can debug this problem further please?

    If it helps, here is the full JSON response from LinkedIn:

Perl Not returning SQL query result
5 direct replies — Read more / Contribute
by santoo
on May 11, 2021 at 08:07

    Hi All, I am trying to run some sql query on perl. I am not getting any error, at the same time also the result is always emty. But when I try same query on sql client I am getting data. Any idea to troubleshoot please

    my $conn = $OracleSqlData::connection{$OracleSqlData::server}; $sth =$conn->prepare("select * from users"); $sth->fetchrow_array()

    updated

    Actually above code is within the method and that method is being called in multiple places and it will return result-set... My problem is for some method calls its returning value but for other calls its giving empty result set... its not consistent across all calls also in log I check for any error randomly I get bellow error also ORA-03113: end-of-file on communication channel Session ID: 1168 Serial number: 37417 (DBD ERROR: OCIStmtExecute)
Net::FTP and Net::FTPSSL Lost data when transferring a large file
3 direct replies — Read more / Contribute
by duy.nguyen
on May 11, 2021 at 01:05
    Hi Monks,

    I use library Net::FTP to transfer a large file (about 7GB) to a remote server.

    But I always received a file that has a size about 5GB.

    If the file is 4GB, it is put to the remote server successfully.

    Is there any limit size for the file transferred by put method?

    I have tried using Net::FTPSSL and I got the same result.

    Thanks.

[OT] github: testing PRs
2 direct replies — Read more / Contribute
by syphilis
on May 11, 2021 at 00:56
    Hi,

    I assume this must be a simple procedure.
    I want to obtain the same perl source code that CI ran in its automated testing of https://github.com/Perl/perl5/pull/18783.
    What is the simplest way for me to obtain that source ?

    Update: I probably should mention that I do already have a fully functional git utility.

    Cheers,
    Rob

Add your question
Title:
Your question:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":