Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much

The Monastery Gates

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

Donations gladly accepted

If you're new here please read PerlMonks FAQ
and Create a new user.

New Questions
Removing text between HTML tags
3 direct replies — Read more / Contribute
by perll
on Sep 14, 2014 at 10:14
    Hi, I am trying to parse HTML data using regex, below is the HTML code
    <td class="body3" valign="top"><p style="margin-top:1ex; margin-botto +m:1ex;">The purpose of this study is to compare two types of care - s +tandard <span class="hit_org">oncology</span> care and standard <span + class="hit_org">oncology</span> care with early palliative care (sta +rted soon after diagnosis) to see which is better for improving the e +xperience of patients and families with advanced lung and non-colorec +tal GI cancer. The study will use questionnaires to measure patients +' and caregivers' quality of life, mood, coping and understanding of +their illness.</p></td>
    I tried to extract the text using below code. ($bs) = $pre_bs =~ m/\>(.*)\</; Information of only 1st tag will be removed, not all. So I tried with this as well,  $bt =~ s/<.*>//gi; but its not working, everything is removed in this case. I want to remove all tags in a line no matter how many are they, tried multiple combinations but nothing is working. Thanks
Porting Commands to Windows
2 direct replies — Read more / Contribute
by Elegant
on Sep 14, 2014 at 04:02
    Hi, I'm trying to port a few things to Windows and I'm fairly certain that how I'm translating them is incorrect despite not receiving any errors.
    $self->sys('/bin/mkdir', '-p', "$self->{tmp}/attach"); $self->sys('cmd /C mkdir', '-p', "$self->{tmp}/attach");

    The first line is the original (works under linux) and the second line is what I thought was correct under Windows. However, I've never see the results of any of my commands. Is my syntax correct? I have many other cases that involve ln, rm, rm -rf, mv, which are all used in the same manner.

    In case you have questions about what sys() is, it's more or less system().

Fill an array in a module ?
3 direct replies — Read more / Contribute
by DarrenSol
on Sep 13, 2014 at 13:37

    I've run across an obstacle in Perl that I didn't expect. Reading through the module tutorial, it appears that this obstacle is intended. Seems odd to me, since the Perl motto is TMTOWTDI.

    The way I'd like to do it seems to me the most logical, but Perl, apparently, says I can't do it this way :( Mayhap my gray-matter processing unit is defective...

    This is the problem : I have a set directory tree I'm working with, and a number scripts that process the files.

    Seems to me the most straight-forward way to handle this would be to load the directory structure, or specific branches of it, into arrays.

    I'd like to make these arrays, and their contents, available to a script by coding them in a module, as I've done with hard-coded variables. Is this something that Perl doesn't want me to do ?

    I've considered either script to traverse the directory tree, or callable sub-routines, but these seem like overkill for a set directory tree. Either one seem to me to be "making an easy thing hard" :P

    An example, with a subset of the directory tree:

    The initial files are downloaded to the DownLoad folder. These are update files for data sets I've already started.

    The files in the DownLoad folder are moved to the appropriate "raw" folder, retained as an archive.

    The "raw" folder files, which are updates, are appended to the existing data from the files in the "processed" folders. The merged data overwrites the files in the "processed" folders.

    The "processed" files are analyzed, with summary reports placed in the "analysis" folders.

    Sample tree structure:

    \DownLoad (top folder, initial downloaded files)

    \DownLoad\Weekly\raw (downloaded Weekly files moved here)
    \DownLoad\Weekly\processed (merged files)
    \DownLoad\Weekly\analysis (file summary reports)

    \DownLoad\Daily\raw (downloaded Daily files moved here)
    \DownLoad\Daily\processed (merged files)
    \DownLoad\Daily\analysis (file summary reports)

    I'm writing scripts to process files in those directories. Then, for example:

    foreach $RawFileName ( $DownLoadFolder )
    { distribution script, files moved to "raw" folders }

    foreach $AppendFileName ( @WeeklyDirTreeArray ) { (script) }
    foreach $AnalyzeFileName ( @DailyDirTreeArray ) { (script) }

    This works, but I'm only able to do this by pasting the array declaration and initialization code in each script. Seems cumbersome and kludgy. If I change or add to the tree in the future, I'll have to propagate the changes manually to each script - more kludgy copy-and-paste.

    Unlike hard-coded variables which most or all of the scripts use, I can't declare the arrays in a module and fill them - which seems to me the logical way to handle hard-coded arrays.

    Writing script to traverse the directory tree would work, but seems like unnecessary overhead for set-in-place traversing routines. And the traversing code would be copied-and-pasted into each script, which still seems kludgy. Likewise if I change or add to the directory - manual editing of the traverse code in each script.

    Creating a callable sub-routine in a module, which would declare and initialize the arrays, would work, but seems to be unnecessarily complicated overhead for a basic programming problem. Again, "making an easy thing hard", which just don't seem very Perl-like :)

Redirect to an XLSX spreadsheet
3 direct replies — Read more / Contribute
by rbholder
on Sep 13, 2014 at 11:48

    Long time listener, first time caller

    I am migrating all my Perl CGI web apps from a Rackspace server to an internal corporate server that is running Centos 6. I use Excel::Writer::XLSX to create a spreadsheet in a folder like /var/www/cgi-bin/app/temp/fName.xlsx and then use a statment like


    The intention is to automatically download the xlsx file like it does on the Rackspace server. The file is being created but I get an HTTP 500 error. I have all the AddTypes and AddHandlers on the internal server as I did on the Rackspace server. I am running Perl 5.20 and Apache 2.2. What gives?

Tk Osx X11 XQuartz
2 direct replies — Read more / Contribute
by Anonymous Monk
on Sep 13, 2014 at 05:35

    Dear Monks

    I developed a Tk software for Windows I deploy as EXE (ActiveState, PerlApp)

    I want now create a OSX Version of the software. I read a lot about the subject. It seems Tk (unfortunately I do not want to rewrite the enitre code, so I have to stik to Tk) needs X11 instaled on the user machine to work. Ok, I could ask user to install X11. But I've read that X11 is no more available, the only option beeing now XQuartz.

    My question is, anyone have experience in creating Perl Tk GUI software and deploying them on users' computer? Any issue with XQuartz? Before I start setting up my environment (I'd need to by a Mac too), I'd like to know if this is something which can be really done.

How to get non-redundant DNA sequences from a FASTA file?
2 direct replies — Read more / Contribute
by supriyoch_2008
on Sep 13, 2014 at 00:43

    Hi Perlmonks

    I am interested in getting the non-redundant DNA sequences from a FASTA file. Two sequences may have different headers but have the same DNA sequence. I want any one of these two sequences with its header in the output, not both. I have written a script ( but it does not give the results I want. I seek help from perl monks to fix this problem.

    Here goes the script

    #!/usr/bin/perl use warnings; $a=">gi1 cds ATG fun >gi2 cds ATG fun >gi3 cds GGG fun"; while ($a=~ m/(>.*?fun)/gs) { $b1=$&; $b2=$&; while ($b1=~ />.*?cds/gs) { $h=$&; $b2=~ s/$h//g; $b2=~ s/fun//g; $seq=$b2; $seq=~ s/\n//; $hdr_seq="$h\n"."$seq\n"; push @hdr_seq1,$hdr_seq; push @only_seq1,$seq; } } # To remove multiple copies (if any): my %seen; # declare a hash my @only_seq=(); my @hdr_seq=(); @only_seq=grep{!$seen{$_}++}@only_seq1; @hdr_seq=grep{!$seen{$_}++}@hdr_seq1; print "\n\n A. Header & sequences are:\n\n"; print join ("\n", @hdr_seq); print "\n"; print "\n B. Only sequences are:\n\n"; print join ("\n", @only_seq); print "\n\n"; $num=0; foreach my $item1 (@only_seq) {$num++; # No.1 curly $seq1=$item1; foreach my $item2 (@hdr_seq) { # No.2 curly if (defined $item2) { $item2=$item2; $item3=$item2;} while ($item2=~ m/>.*cds/gs) { $hdr2=$&; $item3=~ s/$hdr2//; $item3=~ s/\s//; $seq2=$item3; $ele2="$hdr2\n"."$seq2\n"; if ($seq1 eq $seq2) {push @result1,$ele2;} else {push @result1,$ele2;} } } # No.2 curly } # No.1 curly ###################################### my @result=(); @result=grep{!$seen{$_}++}@result1; print "\n C. Non-redundant sequences are:\n\n"; print join ("",@result); print "\n"; exit;

    The results of the script go like:

    Microsoft Windows [Version 6.1.7600] Copyright (c) 2009 Microsoft Corporation. All rights reserved. C:\Users\x\Desktop> A. Header & sequences are: >gi1 cds ATG >gi2 cds ATG >gi3 cds GGG B. Only sequences are: ATG GGG C. Non-redundant sequences are: (This is wrong) >gi1 cds ATG >gi2 cds ATG >gi3 cds GGG

    Correct results for Non-redundant sequences should be like:

    >gi1 cds ATG >gi3 cds GGG
dumping lexical filehandles (updated)
2 direct replies — Read more / Contribute
by LanX
on Sep 12, 2014 at 11:11

    I'm trying to understand how lexical filehandles are dumped:

    > perl use Data::Dumper qw/Dumper/; use Data::Dump; open my $fh,"<",'/tmp/tst'; dd $fh; dd $::{'$fh'}; print Dumper $fh; __END__ \*main::$fh undef $VAR1 = \*{'::$fh'};

    apparently $fh holds the ref to a glob named "\$fh" , i.e. with sigle as part of the name!

    But inspecting the STASH doesn't show this entry...

    I know that the common way to copy a bare filehandle to a scalar is my $fh=\*FH but this is confusing me.

    Is this an implementation workaround or what am I missing?


    Just after posting I'm realizing that I may be inspecting the wrong ($ = scalar) slot of the $fh glob. I'll update further tests.


    OK inspecting only the glob reveals it's existence in the stash:

    dd *{'::$fh'}; # => *main::$fh

    but I'm still a bit confused ...

    So lexical file handles are implemented as hidden global stash entries, which are destroyed when the lexical var falls out of scope ?

    Cheers Rolf

    (addicted to the Perl Programming Language and ☆☆☆☆ :)

Open3 and IO:Select on Win32
2 direct replies — Read more / Contribute
by Elegant
on Sep 12, 2014 at 00:29

    Hi, I'm currently trying to port a project over from linux to Windows and hit a bit of a snag when using Open3 and IO::Select to read both STDOUT and STDERR.

    It appears that if I dump the select handle I never see STDERR get set and I never got into my loop because can_read is never ready. I'm not quite sure of how to work around this on Windows and could really use some help!

    sub sys { my $self = shift; my $app = shift; my ($pid, $in, $out, $err, $sel, $buf); $err = gensym(); more(); TRACE "sys > $app @_"; $pid = open3($in, $out, $err, $app, @_) or LOGDIE "failed to open $app +: @_"; $sel = new IO::Select; $sel->add($out, $err); SYSLOOP: while(my @ready = $sel->can_read) { foreach my $fh (@ready) { my $line = <$fh>; if(not defined $line) { $sel->remove($fh); next; } if($fh == $out) { TRACE "sys < $line"; $buf .= $line; } elsif($fh == $err) { TRACE "sys !! $line"; $buf .= $line; } else { ERROR "Shouldn't be here\n"; return undef; } } } waitpid($pid, 0); less(); return $buf; }

    Using strawberry perl 64bit on Windows 7 x64.

Trying to send SMS from PC to Mobile but unable to select "Send Free SMS" button on the home page
2 direct replies — Read more / Contribute
by ravi teja
on Sep 11, 2014 at 10:11

    Trying to send SMS from PC to Mobile but unable to select "Send Free SMS" button on the home page. Please help how to select options like "Send free SMS" or "Start earnings"after login. Please find the code below that I tried

    use WWW::Mechanize; use Compress::Zlib; use HTML::TokeParser; my $mech = WWW::Mechanize->new(); my $username = ""; my $keyword = ""; my ($text,$mobile); my @mobilenos; my $morenos = $ARGV[0]; @mobilenos = $morenos; print @mobilenos; $text = $ARGV[1]; $deb = 1; print "Total Character of message is ".length($text)."\n" if($deb); $text = $text."\n\n\n\n\n" if(length($text) < 135); $mech->get(""); unless($mech->success()) { print "successed"; exit; } $dest = $mech->response->content; print "Fetching...\n" if($deb); if($mech->response->header("Content-Encoding") eq "gzip") { $dest = Compress::Zlib::memGunzip($dest); $mech->update_html($dest); } $dest =~ s/<form name="loginForm"/<form action='..\/Login1.action' nam +e="loginForm"/ig; $mech->update_html($dest); $mech->form_with_fields(("username","password")); $mech->field("username",$username); $mech->field("password",$keyword); print "Loggin...\n" if($deb); $mech->submit_form(); $dest= $mech->response->content; $mech->click_button(value => "Send Free SMS"); foreach $mobile (@mobilenos){ chomp($mobile); print "\nMessage sending to ".($mobile)."\n"; print "Sending ... \n" if($deb); $mech->field("Mobile Number",$mobile); $mech->field("Message",$text); $mech->click(value => "Send SMS"); if($mech->success()) { print "Done \n" if($deb); } else { print "Failed \n" if($deb); exit; } $dest = $mech->response->content; if($mech->response->header("Content-Encoding") eq "gzip") { $dest = Compress::Zlib::memGunzip($dest); } $x = $mech->content(); open(Myfile,'>',"rt.txt"); print Myfile $x; if($dest =~ m/successfully/sig) { print "Message sent successfully \n" if($deb); } } print "Message sent to all the numbers\n Bye.\n"; exit;
regex to rename last _ with ,
4 direct replies — Read more / Contribute
by Anonymous Monk
on Sep 11, 2014 at 09:01
    I am trying to rename the last _ with a , but not sure how to do that.
    Here is what I have so far-

    my @flist = qw' 1st-device-CA_Eth.0/1 2nd-device-TX_Gig.1/1 '; print "@flist\n"; for my $file (@flist) { $file =~ s{\_[^_]+$}{, }; print "$file\n"; }
    1st-device-CA_Eth.0/1 2nd-device-TX_Gig.1/1 1st-device-CA, 2nd-device-TX,

    Now, how do I get the rest of the info back after that (,)? Please help.
Sharing a database connection across fork()
3 direct replies — Read more / Contribute
by ibm1620
on Sep 10, 2014 at 20:04

    I have a parent process that creates a DBI::mysql connection (held in $dbh) to database D, executes some SQL requests, forks some children, (each of which want to execute SQL requests to the same database), and then continues to execute more SQL. The children of course inherit $dbh, but I'm not having much luck from then on.

    Someone suggested executing $dbh->{InactiveDestroy} = 1; before forking, to prevent the children's exits from clobbering the shared connection. But I get from Sharing a database handle over multiple processes (dated 2001) that you shouldn't expect a database handle to survive the fork.

    So what approach should I take? It sounds like I should disconnect $dbh before I fork (so that no children inherit my connection); have the children each connect afresh; and, back in the parent, *reconnect* to D and continue running.

    Or perhaps I should leave the connection open, issue $dbh->{InactiveDestroy} = 1; before any forking, and have the children simply create their own connections in $dbh_child. When they exit, the $dbh_child connection will be cleaned up, and the inherited $dbh connection will be untouched.

    Thanks for any help!

Undefined value from DBI
3 direct replies — Read more / Contribute
by Anonymous Monk
on Sep 10, 2014 at 11:53
    Hi there Monks!
    I am trying to add this SQL statement to the code and I am getting an error:
    "Can't call method "execute" on an undefined value at line 200."
    It happens even if I try to explicitly put the value into the select. Has anyone done anything like this before?
    Here is the part of the code.
    ... my $search = "joe"; # for testing my $sql = qq{ ;with data_count as ( select sum(case when FIRST = 'joe' then 1 else 0 end) as a_count, sum(case when MIDDLE = 'joe' then 1 else 0 end) as b_count, sum(case when LAST = 'joe' then 1 else 0 end) as c_count from my_table where FIRST like 'joe%' or MIDDLE like 'joe%' or LAST like 'joe%' ) select 'Search by: ' + 'joe' union all select 'Found ' + convert(varchar, a_count) + ' ' + 'joe' + ' for Firs +t' from data_count union all select 'Found ' + convert(varchar, b_count) + ' ' + 'joe' + ' for Midd +le' from data_count union all select 'Found ' + convert(varchar, c_count) + ' ' + 'joe' + ' for Last +' from data_count }; my $sth = $dbh->prepare($sql); $sth->execute() or die "SQL Error: $DBI::errstr\n"; my $data = $sth->fetchall_arrayref({}); warn Dumper $data; ...
    I would like to use place holders as well, in this case any suggestion?
    Thanks for looking!
New Meditations
The Case for Macros in Perl
3 direct replies — Read more / Contribute
by einhverfr
on Sep 12, 2014 at 23:07

    In some of my work I have started doing a lot more with higher order and functional Perl programming. A good example is PGObject::Util::DBMethod which provides a way to declaratively map stored procedures in Postgres to object methods. I have linked to the source code on github above because it is a good example of where macros would be very helpful.

    Now I will be the first to admit that in these cases, macros are not 100% necessary. The module above can accomplish what it needs to do without them. However the alternative, which means effectively creating a highly generalized anonymous coderef, setting up a custom execution environment for that coderef, and then installing the generalized coderef with the specific execution environment as a method has some significant drawbacks.

    Here's the particular section that does the main work:
    sub dbmethod { my $name = shift; my %defaultargs = @_; my ($target) = caller; my $coderef = sub { my $self = shift @_; my %args; if ($defaultargs{arg_list}){ %args = ( args => _process_args($defaultargs{arg_list}, @_) + ); } else { %args = @_; } for my $key (keys %{$defaultargs{args}}){ $args{args}->{$key} = $defaultargs{args}->{$key} unless $args{args}->{$key} or $defaultargs{strict_ar +gs}; $args{args}->{$key} = $defaultargs{args}->{$key} if $defaultargs{strict_args}; } for my $key(keys %defaultargs){ next if grep(/^$key$/, qw(strict_args args returns_objects) +); $args{$key} = $defaultargs{$key} if $defaultargs{$key}; } my @results = $self->call_dbmethod(%args); if ($defaultargs{returns_objects}){ for my $ref(@results){ $ref = "$target"->new(%$ref); } } if ($defaultargs{merge_back}){ _merge($self, shift @results); return $self; } return shift @results unless wantarray; return @results; }; no strict 'refs'; *{"${target}::${name}"} = $coderef; }

    Now that is 40 lines of code and 30 lines of it go into the coderef which is executed when the method is actually run. This doesn't seem too much but it does the work of 5-10 lines of code in an imperative style. In other words, it is 5-6 times as long and intensive as it needs to be.

    With macros, it would be quite possible to generate only the code needed for the specific function rather than creating a generalized case which has to handle many non-applicable inputs, and then create a context where it only gets what it needs.

Log In?

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

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (5)
As of 2014-09-15 04:20 GMT
Find Nodes?
    Voting Booth?

    My favorite cookbook is:

    Results (145 votes), past polls