http://www.perlmonks.org?node_id=479

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
Dereferencing in blessed object
2 direct replies — Read more / Contribute
by Bod
on Feb 25, 2021 at 17:58

    I have a bit of a strange problem... I have consulted the very useful assistance haukex and others provided on Re^9: Preparing data for Template.

    The problem is dereferencing an entry in a hash. At first, I thought it was the trouble I always seem to run into when using references. So, I built some test code to check what I was doing and it works as expected.

    use strict; my $val = 'A'; my $vars = { 'test' => $val }; reftest('testing', $vars); sub reftest { my ($value, %vars) = @_; print "$value\n"; print $$vars{'test'}."\n"; } C:\Users\ian\Perl>perl dereference.pl testing A
    The output is exactly as expected.

    But the code on the webserver is structured the same. The only difference is that the subroutine is a method in a blessed object...could this really make a difference?

    The calling code...

    my $vars = { 'testpage' => $data{'testpage'} }; $html->process('index', $vars);

    And the method within the $html object...

    sub process { my ($self, $disp, %v) = @_; my $testpage = $$v{'testpage'}; print "<h1>".$testpage."</h1>\n"; }
    The output is <h1></h1> only.

    I have checked the $data{'testpage'} contains the expected data of either 'A' or 'B'.
    What is causing the lack of dereferencing or what else could I try to debug this problem?

Passing Variables
4 direct replies — Read more / Contribute
by catfish1116
on Feb 25, 2021 at 16:01

    I am running v5.12 and am trying to pass multiple args to a subroutine. Is this possible in v5.12? Here is my code

    ################################################### # # # 2/24/21 # # Program takes finds the average in an # # array and lists out the numbers that were # # above the average found. # # # ################################################### my @numbers = qw(4 12 18 21 35); my $average = &find_average(@numbers); print "The average found for this list is: $average \n " ; my @high_avg = &above_average($average, @numbers); print "The numbers that were found above average are: @high_avg \n" +; sub find_average { my ($sum, $number_count) ; foreach (@_) { $sum += $_; $number_count += 1; } my $avg = $sum / $number_count ; } sub above_average { my $average_num; my @final_list; foreach $_ (@_) { if ($_ > $average_num) { push @final_list, $_ } } }

    Here is the error message I am getting

    Use of uninitialized value $average_num in numeric gt (>) at ./Chapter +4_Ex3.pl line 36.

    TIA The Catfish

Move a file to another directory based on regex match
4 direct replies — Read more / Contribute
by DAN0207
on Feb 25, 2021 at 09:43

    I am trying to match the regex of the filename and if it matches i want to move the file into another directory.But when i run the script, i get the error as "move failed: Invalid cross-device link".Please help me.The code is given below:

    #!/usr/bin/perl -w use File::Copy; $InDir = $ARGV[0]; $OutDir = $ARGV[1]; if (!opendir(DIR,$InDir)) { print "Bad Dir $InDir\n"; exit 1;} while(my $Infile = readdir(DIR)) { if ($Infile =~ 'F\d{8}\.\d{4}\+\d{4}\-\d{4}\+\d{4}_.*') { move("$Infile", "$OutDir") or die "move failed: $!"; } elsif ($Infile =~ 'F\d{8}\.\d{6}\+\d{4}\-\d{6}\+\d{4}_.*' ) { <.....do something........> } }
You won't believe what this regular expression does!
4 direct replies — Read more / Contribute
by salva
on Feb 25, 2021 at 05:44
Sending file as "TEXT" or "BLOB"
4 direct replies — Read more / Contribute
by cristofayre
on Feb 24, 2021 at 11:49

    This is partially PERL and partially javascript (Sorry)

    Basically, I want to send an HTTPRequest to the server. If the file =DOES NOT= exist, it throws back an error as a TEXT response. If it DOES exist, it passes back the file as a BLOB. (Not really sure how to send a file as a BLOB from PERL - which is the point of this question)

    ** Using "Content-type: attachment; application/zip" and "content-disposition" to invoke the save dialouge I can just about understand ... but that will not report an error if the file doesn't exist. (The file is accessed by user entering a code number into a form, so a wrong number needs to throw an error warning)

    Here is the basic code:

    CLIENT SIDE: function downFile(){ var formData = new FormData(); formData.set('email','$email'); formData.set('gf_line','$line'); formData.set('code','$code'); var xhttp = new XMLHttpRequest(); xhttp.onreadystatechange = function() { if (this.readyState == 4){ if (this.status == 200) { if (xhttp.responseType == 'text' || xhttp.responseType == +'') { alert('Sorry, but there appears to be an error\\nThis coul +d be:\\n\\n- The email address entered\\ndoes not match the email in +database\\n\\n- The code you entered is incorrect\\n\\nPlease check y +our details, and try again'); window.history.back(); return false; } else if (xhttp.responseType == 'blob'){ // Create a new Blob object using the response data of the + onload object var blob = new Blob([this.response], {type: 'application/z +ip'}); //Create a link element, hide it, direct it towards the bl +ob, and then 'click' it programatically let a = document.createElement("a"); a.style = "display: none"; document.body.appendChild(a); //Create a DOMString representing the blob and point the l +ink element towards it let url = window.URL.createObjectURL(blob); a.href = url; a.download = 'Branded Files.zip'; //programatically click the link to trigger the download a.click(); //release the reference to the file by revoking the Object + URL window.URL.revokeObjectURL(url); } } } xhttp.open("POST", "download.pl", true); xhttp.send(formData); } </script> SERVER SIDE: ... .. . if ($inEmail ne $email){ print "content-type: text/html\n\n"; print "500"; # Returned as a "TEXT" response exit; } else{ open FILE, "<", "../data/$user/$dir/$code/$fileCode.zip"; binmode FILE; while(<FILE>){ $file.=$_; } close FILE; #print "content-type: text/html\n\n"; #print "content-type: application/zip\n"; #print "content-disposition: attachment; filename='Branded Files'\n\n" +; print $file; # Returned as a "BLOB" response

    Both responses return as text

    The theory is that the code in the else statement will create a fake anchor, load the blob into it, emulate a click and thus invoke the "SAVE" dialogue. Admit this is "copy / paste" so - whilst I understand what it's doing - it's not my code

    In a nutshell, I want an alert if the file does not exist, or a SAVE dialogue if it DOES exist, ideally without navigating away from the page. There may be an easier way to do it, so open to suggestions

ODBC problem
7 direct replies — Read more / Contribute
by Anonymous Monk
on Feb 24, 2021 at 08:47
    Hi, I have to access an old Sage MAS 90 database, I can connect fine with an ODBC query tool using the connection string "Driver={MAS 90 4.0 ODBC Driver};Directory=S:\v440\MAS90" But when I try with Perl I get:
    use strict; use warnings; use DBI; my $dbuser = "user"; my $dbpassword = "password"; # SOTAMAS90 my $CONNECT = 'Driver={MAS 90 4.0 ODBC Driver};Directory=S:\v440\MAS90 +'; my $dbh = DBI->connect("dbi:ODBC:$CONNECT", "$dbuser", "$dbpassword") or die "Cannot connect to $CONNECT: $DBI::errstr\n"; $dbh->disconnect
    It fails with:
    C:\>test_1.pl DBI connect('Driver={MAS 90 4.0 ODBC Driver}','user',...) failed: [Mic +rosoft][ODBC Driver Manager] Data source name not found and no defaul +t driver specified (SQL-IM002) at C:\test_1.pl line 11. Cannot connect to Driver={MAS 90 4.0 ODBC Driver}: [Microsoft][ODBC Dr +iver Manager] Data source name not found and no default driver specif +ied (SQL-IM002)
    The driver is a 32bit on (if that's relevant) I've also tried using its user DSN name SOTAMAS90 instead but that fails as well. I've never used ODBC before and am not used to working on Windows so any help to helping me connect would be great!
Image rotation with GD: counter or clockwise?
3 direct replies — Read more / Contribute
by Discipulus
on Feb 23, 2021 at 08:29
    Hello folks!

    I'm experimenting with images again but I'm stucked at image rotation using GD. Documentation says:

    > $image->copyRotated($sourceImage,$dstX,$dstY,$srcX,$srcY,$width,$height,$angle) Like copyResized() but the $angle argument specifies an arbitrary amount to rotate the image clockwise (in degrees). In addition, $dstX and $dstY species the center of the destination image, and not the top left corner.

    The following code seems to rotate counter clockwise instead (pass to the following program a jpg image and optionally a degrees value):

    use strict; use warnings; use GD; print "GD version : $GD::VERSION\n"; print "libgd version: ",GD::VERSION_STRING,"\n"; my $original_jpg = $ARGV[0]; my $angle = $ARGV[1] ? $ARGV[1] : 90; my $gd = GD::Image->new( $original_jpg ); my $gdrot = new GD::Image($gd->width, $gd->height ); $gdrot->copyRotated( $gd, # source $gd->width/2, # X center of the destinat +ion image $gd->height/2, # Y center of the destinat +ion image 0, # X specify the upper left + corner of a rectangle in the source image 0, # Y specify the upper left + corner of a rectangle in the source image $gd->width, # final width $gd->height, # final height $angle # rotation angle clockwise + in degrees ); open my $fh,'>', "rotated_".$angle."_".$original_jpg or die $!; binmode $fh; print $fh $gdrot->jpeg;

    Did you see the same result as me? I see the resulting image rotated 90 counter clockwise (I'd say counter documentwise ;). In early tests I got a warning about older version of gdlib (like: libgd 2.0.33 or higher required for copyRotated ) and I upgraded my GD.pm using cpan client and everything went fine.

    I currently have: GD version   : 2.66 libgd version: 2.2.4

    Any insight appreciated.

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Assign valuse of array within array to variables
3 direct replies — Read more / Contribute
by g_speran
on Feb 22, 2021 at 20:29

    Good Evening Perl Monks, How can one assign the contents of an array within a multi-dimensional array to a set of variables passed to a subroutine?

    use warnings; use Data::Dumper; my @arr; $arr[0][4] = (["S","M","R","B"]); print Dumper @arr; my ($VAR1,$VAR2,$VAR3,$VAR4) = @{$arr[0][4]}; print "Var1: $VAR1\tVar2: $VAR2\tVar3: $VAR3\tVar4: $VAR4\n"; Testing($arr[0][4]); sub Testing () { my ($VAR5,$VAR6,$VAR7,$VAR8) = @{$_}; print "Var5: $VAR5\tVar6:$VAR6\tVar7: $VAR7\tVar8: $VAR8\n"; }
    OUTPUT ================= main::Testing() called too early to check prototype at C:\temp\arr_ref +ernce.pl line 11. $VAR1 = [ undef, undef, undef, undef, [ 'S', 'M', 'R', 'B' ] ]; Var1: S Var2: M Var3: R Var4: B Use of uninitialized value $_ in array dereference at C:\temp\arr_refe +rnce.pl line 14. Use of uninitialized value $VAR5 in concatenation (.) or string at C:\ +temp\arr_refernce.pl line 15. Use of uninitialized value $VAR6 in concatenation (.) or string at C:\ +temp\arr_refernce.pl line 15. Use of uninitialized value $VAR7 in concatenation (.) or string at C:\ +temp\arr_refernce.pl line 15. Use of uninitialized value $VAR8 in concatenation (.) or string at C:\ +temp\arr_refernce.pl line 15. Var5: Var6: Var7: Var8:
    Expecting output ============== Var1: S Var2: M Var3: R Var4: B Var5: S Var6: M Var7: R Var8: B
Surprising result when using undef
6 direct replies — Read more / Contribute
by davebaker
on Feb 22, 2021 at 15:39

    I was surprised at this result when I tried to write a couple of lines of code that would prevent an email from going out to an active mailing list, unless I (as the developer) had expressly set "is_dev_mode" to be 0 or 1 in an anonymous hash supplied as the parameter. Without expressly telling the subroutine whether or not we're in development mode, I figured, the subroutine needed to assume that we are, so as not to actually send an email to all of my important customers. So:

    send_email ( { subject => "Test subject", body => "Test body", } ); sub send_email { my $param = shift; my $subject = $param->{subject}; my $body = $param->{body}; my $is_dev_mode = exists $param->{is_dev_mode} ? $param->{is_dev_mode} : undef; $is_dev_mode = 1 unless ( $is_dev_mode == 0 || $is_dev_mode == 1 ) ; # In case the CGI param is ''; default is to be "safe" (is_de +v_mode == 1) _blast_email_to_all_my_important_customers( $subject, $body ) unles +s ( $is_dev_mode ); }

    So I run the code, and... did all my important customers just get an embarrassing test email?

    They sure did. Now, let's add "use strict;" and "use warnings;" and try it again, and throw in a warn statement to try to figure out what's happened.

    use strict; use warnings; send_email ( { subject => "Test subject", body => "Test body", } ); sub send_email { my $param = shift; my $subject = $param->{subject}; my $body = $param->{body}; my $is_dev_mode = exists $param->{is_dev_mode} ? $param->{is_dev_mode} : undef; $is_dev_mode = 1 unless ( $is_dev_mode == 0 || $is_dev_mode == 1 ) ; # In case the CGI param is ''; default is to be "safe" (is_de +v_mode == 1) warn "is_dev_mode is '", $is_dev_mode, "'\n"; _blast_email_to_all_my_important_customers( $subject, $body ) unles +s ( $is_dev_mode ); }

    Result:

    Use of uninitialized value $is_dev_mode in numeric eq (==) at C:\Users +\davel\Desktop\test-of-dev-mode-flag-revised.pl line 19. Use of uninitialized value $is_dev_mode in warn at C:\Users\davel\Desk +top\test-of-dev-mode-flag-revised.pl line 23. is_dev_mode is ''

    Thanks for the warning, but the customers just got ANOTHER email blast.

    OK, I see how $is_dev_mode was undef, and hence the warning. But if $is_dev_mode is undef, then $is_dev_mode is not equal to zero, right? And if $is_dev_mode is undef, then $is_dev_mode is not equal to 1, right? And if neither is true, then the "unless it's true" clause means $is_dev_mode gets 1 as its value (so as to avoid the embarrassing blast to all my important customers), right? Nope! is_dev_mode is still undefined.

    An interesting and surprising result to me. I don't think I'll be setting variables to undef and using them in this kind of boolean test again.

    I would not have thought that "( $an_undefined_variable == 0 )" would evaluate to true because, golly, undef isn't a number and so the "==" operator is testing whether one number is the same as another number. Now, in hindsight of course, it's apparent that the "==" operator is going to convert both sides to a number in order to chug along and do the best it can, and 0 seems to be the closest thing to a number for undef. I think.

Semaphore puzzle
6 direct replies — Read more / Contribute
by jerryhone
on Feb 22, 2021 at 13:12
    Brothers,
    I'm seeking wisdom and potentially flashes of inspiration... I have a process that receives files via NDM from an external partner in pairs - a data file and a status file. The files may arrive in any order, and could be anything from minutes apart to fractions of a second. I'm trying to create a process that populates the file content into an Oracle database via a Perl script triggered after each file arrives. Although the files can arrive in pseudo parallel, I need to process them in sequence, so I'm trying to semaphore lock them (IPC::Semaphore). If they arrive separated by, say, 1 second the lock works nicely, but if they arrive a tenth of a second apart, both Perl processes say that they're the first one and create and initialize the semaphore.
    $sem = IPC::Semaphore->new( 4321, 1, S_IRUSR | S_IWUSR ); if ( $sem ) { # Semaphore already exists so just open it print "Semaphore already exists - just open it\n"; $sem = IPC::Semaphore->new( 4321, 1, S_IRUSR | S_IWUSR ); } else { # The semaphore didn't already exit so create it print "Create semaphore \n"; $sem = IPC::Semaphore->new( 4321, 1, IPC_CREAT | S_IRUSR | S_IWUSR + ); print "Semaphore created\n"; $sem->setval(0,1); print "Semaphore initialised\n"; } print "Locking other threads\n"; $sem->op(0, -1, SEM_UNDO);
    Depending on exact timing, I see that it's possible for the first process to create the semaphore and attempt to lock the other process, but the other one running a fraction behind has not detected the creation so it does its own and sets the semaphore to 1, so revoking it's partner's lock! I can't see a fool proof way of getting around this, so any divine inspiration gratefully received.
    Jerry

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":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.