Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

Seekers of Perl Wisdom

( #479=superdoc: print w/ replies, xml ) Need Help??

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. Post a new question!

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.

User Questions
Overloading the name of a proposed download
1 direct reply — Read more / Contribute
by RenardBleu
on Jul 10, 2014 at 05:08
    Hi monkers, I need to be able to propose files to ba downloaded but i have to read and print the file in my CGI. I tried to go for :
    #!/usr/bin/perl -w use strict; push( @INC, $lib_directory ); require 'lib_utils.pl'; dl_file('/tmp/final.pdf');
    as main page (dl.pl) and
    sub dl_file { my ($file) = @_; if ( ! -e $file) { print "file does not exist"; return 0; } my $content = read_file( $file, binmode => ':utf8' ) ; $file =~ m#(.*)([^/]*)$#; my $directory = $1; my $filename = $2; `echo $directory$filename >> /tmp/flag2`; chdir $directory; my $form = new CGI; print $form->header( -type => 'application/octet-stream', -attachment => $filename, -filename => $filename, -Content-Disposition => "attachment; filename=$filename", ); $form->print($content); return 1; }
    for the called function Funny thing is, this code workes just fine if i dont go for a sub and have all the code in dl.pl BUT as soon as i move the code in a sub, the downloaded file is called after the script (ie dl.pl) How would you change it or how would you do ? Thanks in advance for your help
mod_perl odd behaviour with system() or exec() call or backticks
3 direct replies — Read more / Contribute
by pucek
on Jul 10, 2014 at 04:52

    Dear Monks. I developped a simple script in Perl that let's me verify if USB key is mounted or not and eventually unmount it.

    I am not sure if problem is related to programming or configuration...

    Basic issue is: When I execute those scripts in terminal using `Perl` it works perfectly fine, althou when I do it in the browser using `mod_perl` it shows some pretty odd behaviour.

    Sources

    panelmin.pl

    This program simply outputs a message that indicates if the system device `/dev/sda1` is mounted in the system.

    #!/usr/bin/perl use strict; use warnings; print "Content-type:text/html\n\n"; print "<html><head><title>USB test</title>"; print "</head><body>"; my $mounted = `df -h | grep /dev/sda1`; if ($mounted eq '') { print '<h1>USB device not connected</h1>'; print $mounted; } else { print '<h1>Device is connected</h1>'; } print '</body></html>';

    umount.pl

    This program umounts the `/dev/sda1` device from the system.

    #!/usr/bin/perl print "Content-type:text/html\n\n"; print "<html><head><title>Umount</title></head><body>"; system("sudo", "umount", "/dev/sda1"); print "</body></html>";

    Test scenario

    1. Manually mounting the device `/dev/sda1`, (it is declared in `fstab`):

    $ mount -a

    Making sure the device is mounted in the system:

    $ mount /dev/sda1 on /mnt/usbstick type vfat (rw,relatime,uid=1000,gid=100 +0,fmask=0137,dmask=0027,codepage=437,iocharset=ascii,shortname=mixed, +utf8,errors=remount-ro)

    2. Executing `panelmin.pl` in the web browser (I will use curl for the purpose of clean output):

    $ curl http://localhost/cgi-bin/admin/Q/panel/panelmin.pl <html><head><title>USB test</title></head><body><h1>Device is conn +ected</h1></body></html>

    As we can see, the output is correct. It detected the through linux command `df -h` that the device `/dev/sda1` is mounted in the system.

    2. Executing `umount.pl` in the web browser in order to umount the device:

    $ curl http://localhost/cgi-bin/admin/Q/panel/umount.pl <html><head><title>Umount</title></head><body></body></html>

    3. Verifying if the device is umounted using both `panelmin.pl` script in the web browser and linux command line.

    $ curl http://localhost/cgi-bin/admin/Q/panel/panelmin.pl <html><head><title>USB test</title></head><body><h1>USB device not + connected</h1></body></html>

    Seems to be correct, but let's verify it manually with `df -h` command:

    $ df -h | grep /dev/sda1 /dev/sda1 15G 366M 15G 3% /mnt/usbstick

    As we can see the device is still mounted in the system.

    4. Let's retry the whole process but this time instead of executing scripts in the browser we will launch them manually with `Perl` in the terminal. First lets umount the device. This will also show that the user is in sudoers and script can umount it.

    $ sudo umount /dev/sda1 $ df -h | grep /dev/sda1

    Let's repeat the process.

    $ mount -a (as superuser) $ df -h | grep /dev/sda1 /dev/sda1 15G 366M 15G 3% /mnt/usbstick

    And finally the test:

    $ perl panelmin.pl Content-type:text/html <html><head><title>USB test</title></head><body><h1>Device is conn +ected</h1></body>
    $ perl umount.pl Content-type:text/html <html><head><title>Umount</title></head><body></body></html>
    $ perl panelmin.pl Content-type:text/html <html><head><title>USB test</title></head><body><h1>USB device not + connected</h1></body></html>
    $ df -h | grep /dev/sda1
    Now `df -h | grep /dev/sda1` returned empty string, it has proven that `umount.pl` managed to umount the device from the system, but only if executed in the shell with `Perl`.

    Attempts to solve the issue

    • Making sure the user who executes `sudo umount /dev/sda1` in `umount.pl` has right to do so, I verified it by executing `whoami` inside the script and printing it in the output.
    • Trying different syntax of `system()`, for example separating the arguments or executing it all as one command.
    • I verified if my mod_perl executes scripts in `taint mode`, because I heard it may influence executing external processes. As a matter of fact in my `httpd.conf` there is no `PerlTaintCheck On` and if I understand it correctly, it would influence the execution with dynamic arguments (for security reasons), in case of my script it is same command each time.
    • I tryed to use different functions, replace `System` by `Exec` or by backticks etc.
    • I tryed to use `Apache2::SubProcess`, but I must admit I'm not sure if I did it correctly, I'm new to Perl and this (and all other available on net) example is just horrible, for example `$r` variable is never initiated in their code, I just declarated it as `Apache2::RequestRec object`, it didn't work.
    • I tryed to change env variables like they explained in mod_perl doc in subsection `10.2.6. Starting a Long-Running External Program` (can't add link because your bot thinks I'm a spammer...)
    • I verified the logs in Apache directory, have found errors but not related to those scripts, I didn't post them here because I didn't wanted it to bee too messy.
    • I captured the output of external command calls, it is void except if I umount device if it is already unmount and ejected. Then obviously it says that there is no `/dev/sda1` device.
    • I've been recommended to try to add the following directive, unfortunately it didn't help.
      use autodie qw(:all)

    Interpretation

    The fact it works with `Perl` and not with `mod_perl` is not that surprising, what I find the most strange is with `mod_perl` the script `panelmin.pl` seems to works fine with it's `system()` launch and suddenly after executing `umount.pl` it does not work correctly anymore. For now I am out of ideas, I find this behaviour odd and I count on you guys. I hope someone knows what should I do. Thanks.

Copy dir with space
4 direct replies — Read more / Contribute
by adriang
on Jul 10, 2014 at 04:38

    Hi All,

    How can I copy/move dir with space. The Below code does not work.

    opendir(my $dir, "/pr/perl_by_example") or die; opendir(my $dir2, "/pr/book") or die; while (my $file=readdir($dir)) { next if $file =~ /\./; copy("/pr/perl_by_example/$file", "/pr/book/") or die; }

    Here are the dirs:

    /pr/perl_by_example/Chapter 03 /pr/perl_by_example/Chapter 04 /pr/perl_by_example/Chapter 05 /pr/perl_by_example/Chapter 06 /pr/perl_by_example/Chapter 07 /pr/perl_by_example/Chapter 08 /pr/perl_by_example/Chapter 09 /pr/perl_by_example/Chapter 10 /pr/perl_by_example/Chapter 11 /pr/perl_by_example/Chapter 12 /pr/perl_by_example/Chapter 13 /pr/perl_by_example/Chapter 14 /pr/perl_by_example/Chapter 15 /pr/perl_by_example/Chapter 16 /pr/perl_by_example/Chapter 17 /pr/perl_by_example/Chapter 18 /pr/perl_by_example/Chapter 19 /pr/perl_by_example/Chapter 20

    Thanks in advance

Meaning of command
4 direct replies — Read more / Contribute
by grewal7634
on Jul 09, 2014 at 23:56

    $A =~ tr[\n][]d;

    In this what is the meaning of =~ tr[\n][]d;

sprintf("%ss", ...)
3 direct replies — Read more / Contribute
by v_melnik
on Jul 09, 2014 at 16:47

    Maybe this question is way too simple, but the help will be greatly appreciated.

    I want sprintf("%d %ss have been loaded", 13, "volume"); to return: "13 volumes have been loaded". In other words, I want to use "s" character after "%s" in sprintf(). How to do that?

    Thanks to all!

    V.Melnik
Client Server
2 direct replies — Read more / Contribute
by TheVend
on Jul 09, 2014 at 14:54
    I need a very basic server client that does the following.

    Server: Echo's back to client the clients IP address. Logs the clients IP address.

    Client: Attempts to connect to server and if successful displays the servers echoed IP.

    I have some “borrowed” server code but can’t seem to get it to echo the connected clients IP

    SERVER

    use strict; use Socket; # use port 7890 as default my $port = shift || 7890; my $proto = getprotobyname('tcp'); my $server = "localhost"; # Host IP running the server # create a socket, make it reusable socket(SOCKET, PF_INET, SOCK_STREAM, $proto) or die "Can't open socket $!\n"; setsockopt(SOCKET, SOL_SOCKET, SO_REUSEADDR, 1) or die "Can't set socket option to SO_REUSEADDR $!\n"; # bind to a port, then listen bind( SOCKET, pack_sockaddr_in($port, inet_aton($server))) or die "Can't bind to port $port! \n"; listen(SOCKET, 5) or die "listen: $!"; print "SERVER started on port $port\n"; # accepting a connection my $client_addr; while ($client_addr = accept(NEW_SOCKET, SOCKET)) { # send them a message, close connection my $name = gethostbyaddr($client_addr, AF_INET ); print NEW_SOCKET "Smile from the server"; print "Connection recieved from $name\n"; close NEW_SOCKET; }

    CLIENT

    use strict; use Socket; # initialize host and port my $host = shift || 'localhost'; my $port = shift || 7890; my $server = "localhost"; # Host IP running the server # create the socket, connect to the port socket(SOCKET,PF_INET,SOCK_STREAM,(getprotobyname('tcp'))[2]) or die "Can't create a socket $!\n"; connect( SOCKET, pack_sockaddr_in($port, inet_aton($server))) or die "Can't connect to port $port! \n"; my $line; while ($line = <SOCKET>) { print "$line\n"; } close SOCKET or die "close: $!";
Uninitialized value in division and Illegal division by zero fix
7 direct replies — Read more / Contribute
by To_Bz
on Jul 09, 2014 at 12:57
    I have the following code to get the nucleotide frequency of DNA subfragments.
    my $file1=shift; my @array=('A','T','C','G','AA','AT','AG','AC','TA','TT','TG','TC','GA +','GT','GG','GC','CA','CT','CG','CC','AAA','AAT','AAG','AAC','ATA','A +TT','ATG','ATC','AGA','AGT','AGG','AGC','ACA','ACT','ACG','ACC','TAA' +,'TAT','TAG','TAC','TTA','TTT','TTG','TTC','TGA','TGT','TGG','TGC','T +CA','TCT','TCG','TCC','GAA','GAT','GAG','GAC','GTA','GTT','GTG','GTC' +,'GGA','GGT','GGG','GGC','GCA','GCT','GCG','GCC','CAA','CAT','CAG','C +AC','CTA','CTT','CTG','CTC','CGA','CGT','CGG','CGC','CCA','CCT','CCG' +,'CCC','AAAA','AAAT','AAAG','AAAC','AATA','AATT','AATG','AATC','AAGA' +,'AAGT','AAGG','AAGC','AACA','AACT','AACG','AACC','ATAA','ATAT','ATAG +','ATAC','ATTA','ATTT','ATTG','ATTC','ATGA','ATGT','ATGG','ATGC','ATC +A','ATCT','ATCG','ATCC','AGAA','AGAT','AGAG','AGAC','AGTA','AGTT','AG +TG','AGTC','AGGA','AGGT','AGGG','AGGC','AGCA','AGCT','AGCG','AGCC','A +CAA','ACAT','ACAG','ACAC','ACTA','ACTT','ACTG','ACTC','ACGA','ACGT',' +ACGG','ACGC','ACCA','ACCT','ACCG','ACCC','TAAA','TAAT','TAAG','TAAC', +'TATA','TATT','TATG','TATC','TAGA','TAGT','TAGG','TAGC','TACA','TACT' +,'TACG','TACC','TTAA','TTAT','TTAG','TTAC','TTTA','TTTT','TTTG','TTTC +','TTGA','TTGT','TTGG','TTGC','TTCA','TTCT','TTCG','TTCC','TGAA','TGA +T','TGAG','TGAC','TGTA','TGTT','TGTG','TGTC','TGGA','TGGT','TGGG','TG +GC','TGCA','TGCT','TGCG','TGCC','TCAA','TCAT','TCAG','TCAC','TCTA','T +CTT','TCTG','TCTC','TCGA','TCGT','TCGG','TCGC','TCCA','TCCT','TCCG',' +TCCC','GAAA','GAAT','GAAG','GAAC','GATA','GATT','GATG','GATC','GAGA', +'GAGT','GAGG','GAGC','GACA','GACT','GACG','GACC','GTAA','GTAT','GTAG' +,'GTAC','GTTA','GTTT','GTTG','GTTC','GTGA','GTGT','GTGG','GTGC','GTCA +','GTCT','GTCG','GTCC','GGAA','GGAT','GGAG','GGAC','GGTA','GGTT','GGT +G','GGTC','GGGA','GGGT','GGGG','GGGC','GGCA','GGCT','GGCG','GGCC','GC +AA','GCAT','GCAG','GCAC','GCTA','GCTT','GCTG','GCTC','GCGA','GCGT','G +CGG','GCGC','GCCA','GCCT','GCCG','GCCC','CAAA','CAAT','CAAG','CAAC',' +CATA','CATT','CATG','CATC','CAGA','CAGT','CAGG','CAGC','CACA','CACT', +'CACG','CACC','CTAA','CTAT','CTAG','CTAC','CTTA','CTTT','CTTG','CTTC' +,'CTGA','CTGT','CTGG','CTGC','CTCA','CTCT','CTCG','CTCC','CGAA','CGAT +','CGAG','CGAC','CGTA','CGTT','CGTG','CGTC','CGGA','CGGT','CGGG','CGG +C','CGCA','CGCT','CGCG','CGCC','CCAA','CCAT','CCAG','CCAC','CCTA','CC +TT','CCTG','CCTC','CCGA','CCGT','CCGG','CCGC','CCCA','CCCT','CCCG','C +CCC'); my $name1=""; my $seq1=""; my %counts=(); my %counts_1=(); my %counts_2=(); my %counts_3=(); my %counts_4=(); my %total_mono=(); open (IN, "<$file1") or die ("Couldn't open file $file1\n"); while (my $i=<IN>){ next unless ($i =~ /\w+/); chomp($i); if ($i =~ /^>(\S+)/){ unless ($seq1 eq ""){ $seq1 =~ s/[^ATCG]//g; &process_nuc($seq1, $name1); } $seq1=""; $name1=$1; }else{ $seq1.=uc($i); } } close IN; $seq1 =~ s/[^ATCG]//g; &process_nuc($seq1, $name1); print "Matrix_"; print scalar(@array); for (my $k=0; $k<@array; $k++){ print "\t$array[$k]"; }print "\n"; my %norm_1=(); my %norm_2=(); my %norm_3=(); my %norm_4=(); foreach my $k (keys (%counts)){ print "$k"; 60 my $value=0; 61 $norm_1{'A'}=$counts_1{$k}{'A'}/$total_mono{$k}; 62 $norm_1{'T'}=$counts_1{$k}{'T'}/$total_mono{$k}; 63 $norm_1{'C'}=$counts_1{$k}{'C'}/$total_mono{$k}; 64 $norm_1{'G'}=$counts_1{$k}{'G'}/$total_mono{$k};

    When I executed, I got results and the following error message:

    Use of uninitialized value in division (/) at ./n_f.pl line 61.

    Illegal division by zero at ./n_f.pl line 61.

    I tried to use eval BLOCK as recomended in http://www.perlmonks.org/?node_id=369002, but it didn´t help that much because I get the same error message. I know that first message is a warning, but how can I know if this affects my results?.

    Also, I´m not quite sure if the second message is an error or a warning, so I don´t know if this made the script to stop.

    I´ll appreciate the help.

How to implement a checkbox that will send data to db
2 direct replies — Read more / Contribute
by terrykhatri
on Jul 09, 2014 at 12:53
    Hi, Now I have a situation where I have to use a check box. The db table column has a Boolean data type i.e. True or False
    Column | Type | M +odifiers ----------------+--------------------+-------------------------------- +------ Discontinued | boolean | default false select distinct("Discontinued") from "Products"; Discontinued -------------- f t (2 rows)
    Will appreciate if you monks help me implement it in my ADD and EDIT forms :
    my @options = ("True", "False"); <form action="" method="post"> Discontinued :<input type="checkbox" name="discontinued" value=$option +s><br> </form>
    If its checked it should send a TRUE value to the database else False. Many thanks in advance Rgds Terry Please Note : I will post it to PerlGuru as well.
How to keep the order of keys in hash
2 direct replies — Read more / Contribute
by thanos1983
on Jul 09, 2014 at 12:21

    Dear Monks,

    I am trying to process text folders as a user input. It is important for me the order of the files as they will be printed to be the same as the input.

    So far and based on your help I manage to find a possible solution using two different ways 1) ARRAYS OF ARRAYS and 2) HASHES OF HASHES.

    Based on what I have read online, sort should be more than enough and should keep the correct order of my keys.

    Sample of working code is provided under:

    But for example when I give the file order: sample.txt sample_2.txt sample_3.txt

    File samples:

    Unfortunately this is not happening, because the order of the keys.

    I went online and I found that there is a module Tie::IxHash that could help me with the shorting process.

    I tried to use in my code with the syntax like:

    my $t = Tie::IxHash->new(%hash); $t->SortByKey; print Dumper(\$t);

    But again the output was not in correct order.

    At this point I am wondering, what I am doing wrong. Any suggestions or ideas would be much appreciated.

    Seeking for Perl wisdom...on the process...not there...yet!
How to debug .lib files?
1 direct reply — Read more / Contribute
by crusty_collins
on Jul 09, 2014 at 11:25
    Most venerable monks i have a question for you.

    I am working on legacy code and they used lib files to house all of their functions. The coder uses require to load the function. What is the best way to debug these? Here is snippet of their code The run.pl sets up the environment and then the Currency.pl runs. -- /jet/prod/run.pl /jet/prod/Currency.pl

    relavant piece of /jet/prod/Currency.pl
    require "$mainProcDir/lib/getCurrencyOrderFiles.lib"; # MAIN PROCESSING SUBROUTINE %mainVars; $mainVars = \%mainVars; main($msgLVL);
    the main function of lib/getCurrencyOrderFiles.lib
    sub main { my ($msgLVL) = @_; my $sub = 'main'; print "-- Beginning [$sub]\n" if $msgLVL > 1; getInitParms($msgLVL); my @files = getFiles($msgLVL); # # my @files = ("chi_Currency_20130828*.txt"); for my $file (@files) { print "\t FILE -> $file\n" if $msgLVL > 1; moveFile($msgLVL,$file); stageExtTblFiles($msgLVL,$file); my $batch_id = loadOrders($msgLVL); archiveFiles($msgLVL, $batch_id); } print "-- Leaving [$sub]\n" if $msgLVL > 1; }

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!
  • 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
  • Outside of code tags, you may need to use entities for some characters:
            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.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (11)
    As of 2014-07-10 12:08 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      When choosing user names for websites, I prefer to use:








      Results (207 votes), past polls