Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
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
Improving if statements
2 direct replies — Read more / Contribute
by Anonymous Monk
on Sep 18, 2014 at 19:10
    Hi Monks!
    I have the same kind of logic in my code, it seems redundant and I am trying to improve it, but I am running out of options. Is there a better way to have all this code in a hash and match against what comes in from the

    my $item = $q->param( 'item' ) || '';

    Here is the code I am trying to improve:
    #!/usr/bin/perl use strict; use warnings; use CGI; use Data::Dumper; my $q = CGI->new(); print $q->header(); my $item = $q->param( 'item' ) || ''; my $change; # Get values if($item=~/test/) { $change = "blue"; }elsif($item=~/dark/){ $change = "black"; }elsif($item=~/white/){ $change = "light"; }elsif($item=~/house/){ $change = "home"; }elsif($item=~/all things/){ $change = "multi"; }elsif($item=~/money/){ $change = "value"; }elsif($item=~/country/){ $change = "USA"; }else{ $change = "neutral"; } print "Final Item = $change";
    Thanks for the help!
Passing arguments to event handlers in WxPerl
3 direct replies — Read more / Contribute
by pwn01
on Sep 18, 2014 at 14:44

    I'm trying to retool to Perl from Ansi C (dabbled only slightly in C++ years ago.) I am writing an app that uses a database. I pull the needed data from the database at the beginning of Package MyFrame, and then attempt to handle an EVT_COMBOBOX, but can't seem to pass data to the event handler. I basically need to get the selected combo box entry to the event handler sub so that I can use it in the sub. How is this done? (I'm familiar with passing pointers in C. I think that "aliasing" may be analogous to that, but I don't know how it's done in Perl.) I've made a few vain attempts, but can't seem to find examples for Perl WxWidgets that apply. So far my code is simply in a proof-of-concept state (cut and paste from examples with a few adjustments of my own). So sub Combobox1action is generic and has nothing in it but place holding code. It does execute in its present state, but I'm at a stalemate with it. Below is the MyFrame package.

    package MyFrame; use base 'Wx::Frame'; use Wx::Event qw(EVT_BUTTON EVT_COMBOBOX ); my $sth; my $tablename; my $sqlcommand; my @lessonnumber; my @lessonsimplename; my @lessontitle; my @startingpagenumber; my $nameargument; my $increment = 0; my $dbh = DBI->connect("dbi:mysql:*********", "root","*******") or die "Can't connect to MySQL database: $DBI::errstr\n"; $sqlcommand = "SELECT lessonstring, lesson_number, description, starti +ng_pagenumber FROM lesson_titles"; $sth = $dbh->prepare ($sqlcommand) or die "Cannot perform SQL INSERT: $DBI::errstr\n"; $sth->execute( ) or die "Cannot perform execute\n"; for ( $increment = 1; $increment <= 132; $increment++ ) { ( $lessonsimplename [ $increment-1 ], $lessonnumber[ $increment-1 + ], $lessontitle [ $increment-1 ], $startingpagenumber [ $increment-1 ] ) = $sth->fetchrow_array() +; } $sth->finish; $dbh->disconnect or warn "Disconnect failed: $DBI::errstr\n"; #for ( $increment = 1; $increment <= 132; $increment++ ) { # print ($lessonsimplename [ $increment ].": ".$lessontitle [ $incr +ement ]." p. ".$startingpagenumber [ $increment ]."\n"); #} sub new { my $ref = shift; my $self = $ref->SUPER::new( undef, # parent window -1, # ID -1 means any '********', # title &Wx::wxDefaultPosition, # defaul +t position [200, 200] # size ); my $panel = Wx::Panel->new( $self, # parent window -1, # ID ); my $button1 = Wx::Button->new( $panel, # parent window -1, # ID 'Click me 1!', # label [50, 20], # position &Wx::wxDefaultSize # default s +ize ); my $button2 = Wx::Button->new( $panel, # parent window -1, # ID 'Click me 2!', # label [50, 50], # position &Wx::wxDefaultSize # default s +ize ); my $button3 = Wx::Button->new( $panel, # parent window -1, # ID '*********', # label [50, 80], # position &Wx::wxDefaultSize # default s +ize ); my $combobox1 = Wx::ComboBox->new( $panel, -1, $lessonsimplename[ 0 ], [50, 110], [-1, -1], \@lessonsimplename, 0, &Wx::wxDefaultValidator, '' ); EVT_BUTTON( $self, $button1, \&Button1Click ); EVT_BUTTON( $self, $button2, \&Button2Click ); EVT_BUTTON( $self, $button3, \&Button3Click ); EVT_COMBOBOX( $self, $combobox1, \&Combobox1action ); return $self; } sub Button1Click { my( $self, $event ) = @_; $self->SetTitle( 'Button 1 Clicked' ); } sub Button2Click { my( $self, $event ) = @_; $self->SetTitle( 'Button 2 Clicked' ); } sub Button3Click { my( $self, $event ) = @_; $self->SetTitle( '*********' ); } sub Combobox1action { my( $self, $event ) = @_; $self->SetTitle( 'Combo box selected' ); }

    Thanks.

Duplicate XML Node Question
1 direct reply — Read more / Contribute
by omegaweaponZ
on Sep 18, 2014 at 12:58
    Hi all, I have a question in how to handle parsing out node values that have the same title. Right now when I use Lib XML it finds the nodes, but dumps them altogether as one string. I need to be able to separate them out uniquely. Any good/easy way to do that? Here's an example:
    <parent_node> <node1><child_node>stuff_I_can_get</child_node></node1> <node2><child_node_a>stuff_I_want_1</child_node_a></node2> <node2><child_node_a>stuff_I_want_2</child_node_a></node2> </parent_node>
    So I can grab node1's value of "stuff I can get" without issue, but when I grab node2's value under "child node a", since both are called node2 and child node a, both ""stuff_I_want_1" and "stuff_I_want_2" come back together as one string and would return as "stuff_I_want_1stuff_I_want2" ....my code is:
    foreach $test($dom->findnodes('/parent_node')) { $mystring = $test->findnodes('./node2/child_node_a'); }
    So I need a way to identify both nodes uniquely somehow even though they are called the exact same thing but have two different values
Perl: Regular Expression
2 direct replies — Read more / Contribute
by sravs448
on Sep 18, 2014 at 12:58
    Hi Monks, I have an array of files. Each file with few lines of text, out of which I am trying to get few specific strings through regex in perl Update: Updated as per Choroba's suggestion.
    use strict; use warnings; foreach my $myfile (@myFiles) { open my $FILE, '<', $myfile or die $!; while (my $line = <$FILE>) { my ($project, $value1, $value2) = <Reg exp> ,$line; print "Project : $1 \n"; print "Value1 : $2 \n"; print "Value2 : $3 \n"; } close (FILE); }

    File Content

    Checking Project foobar <few more lines of text here> Good Files excluding rules: 15 - 5% Bad Files excluding rules: 270 - 95% Good Files including rules: 15 - 5% Bad Files including rules: 272 - 95% <few more lines of text here>

    Desired Output

    Project :foobar Value1 : Good Files excluding rules: 15 - 5% Bad Files excluding rules: 270 - 95% Value2 : Good Files including rules: 15 - 5% Bad Files including rules: 272 - 95%
DBI false error
1 direct reply — Read more / Contribute
by kyledba2013
on Sep 18, 2014 at 12:34

    First off, if you are reading this you have already given some of your time to help solve the problem. Therefore, thank you.

    Secondly, to put to give you some background of my Perl knowledge, I know enough to be dangerous but not enough to be known as an expert or Perl developer for that matter. So please don't judge too harshly if you see an obvious mistake. Also you may have to explain something a little more than usual.

    I have a script that forks process to create multiple tables at once. The script gets the DDL needed for a table and then runs a $dbh->do command. The script works well for the most part. However, there are 4 tables out of 5000 that consistently fail. No error string is in $dbh->errstr, $dbh->err, or DBI::errstr. My connect code is:

    my $dbh = DBI->connect("$connection", "$user", "$pass", {PrintError => 0, PrintWarn => 0, RaiseError => 1, LongReadLen => 2000000100, # add 100 to the longest possible long +, as per DBI man page ora_module_name => $base_scriptname # set module name for this s +ession to the name of this script. }) or error_check('N','Y','N',"Could Not Connect To Database: ". $DBI +::errstr);

    my do script is:

    $rows = $source_dbh->do($ctas_sql) or { print sample_table_log "Create table failed at " . get_date() +. "\n" and print sample_table_log "Value for rows is: [$rows]\n" and print sample_table_log "\nCannot run $ctas_sql \n" and print sample_table_log 'DBI::errstr = ' . DBI::errstr . "\n" a +nd print sample_table_log '$source_dbh->errstr = ' . $source_dbh- +>errstr . "\n" and print sample_table_log '$source_dbh->err = ' . $source_dbh->er +r . "\n" and update_sample_table_driver_tb($t_owner,$t_name,'FAILED') and exit 1 };

    I am in debugging mode right now, that is why you see so many print error strings. Here is the log generated:

    Create table failed at 09/18/14 10:58:07 Value for rows is: [] Cannot run CREATE TABLE "sampler_user"."table" SEGMENT CREATION IMMEDIATE PCTFREE 0 PCTUSED 40 INITRANS 1 MAXTRANS 255 NOCOMPRESS NOLOGGING STORAGE(INITIAL 65536 NEXT 1048576 MINEXTENTS 1 MAXEXTENTS 214748364 +5 PCTINCREASE 0 FREELISTS 1 FREELIST GROUPS 1 BUFFER_POOL DEFAULT FLASH_CACHE DEFAULT CELL_FLASH_CACHE DEFAULT) TABLESPACE "S_BCM_DATA" PARALLEL 32 as select a.* from BCM.RESPONSE_CAMP_TB a DBI::errstr = $source_dbh->errstr = $source_dbh->err =

    However, i can go into the database and see the table created. My biggest question is, why does the script run fine for all the other tables but not for these. I can run the sql in sqlplus just fine as well in Toad.

    I just ran this outside of my sampler script. Here is a full code that you can test with:

    #!/usr/bin/perl use strict; use DBI; use Getopt::Long; use File::Basename; require "/home/fdsprod/bin/setoraenv.pl"; ###build connection strings my $HOST=`hostname`; my $sid="$ENV{ORACLE_SID}"; my $source_connection_string=qq(dbi:Oracle:host=$HOST;sid=$sid); my $source_dbh = connect_to_db($source_connection_string); my $rows; create_table(); ###################################################################### +############### # Connect To the source Database. ###################################################################### +############### sub connect_to_db { my $errormessage; # get the base filename for this script my $base_scriptname = basename($0); my $user = 'sampler_fdsglobal'; my $pass = 'sample'; # Just connect to the db. my $connection = $_[0]; my $dbh = DBI->connect("$connection", "$user", "$pass", {PrintError => 0, PrintWarn => 0, RaiseError => 1, LongReadLen => 2000000100, # add 100 to the longest possible long +, as per DBI man page ora_module_name => $base_scriptname # set module name for this s +ession to the name of this script. }) or error_check('N','Y','N',"Could Not Connect To Database: ". $DBI +::errstr); return $dbh; } ###################################################################### +############### # Connect To the source Database. ###################################################################### +############### sub create_table{ my $t_owner = 'BCM'; my $t_name = 'RESPONSE_CAMP_TB'; my $sample_tblspc = 'S_BCM_DATA'; my $t_multi = 'NO'; my $t_condition = ''; my ($sql, $sth, $rows); my $ctas_sql; ##get ddl for table. The below will remap to new schema and table +s $sql = qq(select SYS.sampler_return_ddl_test(upper('$t_owner'),upp +er('$t_name'),'NO','$sample_tblspc') FROM DUAL); $sth = $source_dbh->prepare($sql) or { print "Prepare Error: $sql \n" . $source_dbh->errstr . "\n" an +d exit 1 }; $sth->execute() or { print "Execute Error: $sql \n". $source_dbh->errstr ." \n" and + exit 1 }; $ctas_sql = $sth->fetchrow_array(); ##send email failure if $ctas is null. if (!$ctas_sql){ error_check('N','Y','N',"Create table as sql varabie is null\n +") }; ##in oder to run a 'create table as' statement. you must delete t +he column definitions ##the below regular expression deletes the first instance of a par +enthesis group and its contents, ##which is the column definition when pulled from dbms_metadata. +The dbms_metadata is the ##foundation of the sys.sampler_return_ddl function. DO NOT DELET +E THE FOLLOWING REGULAR EXPRESSION $ctas_sql =~ s/\((?>[^()]|(?R))*\)//; $ctas_sql = $ctas_sql . qq(\nas \nselect a.* from $t_owner.$t_name + a $t_condition); print "Begin Create table at ". get_date() ."\n\n"; print "Value for ctas_sql is:\n$ctas_sql\n\n\n"; $rows = $source_dbh->do($ctas_sql) or { print "Create table failed at " . get_date() . "\n" and print "Value for rows is: [$rows]\n" and print "\nCannot run $ctas_sql \n" and print 'DBI::errstr = ' . DBI::errstr . "\n" and print '$source_dbh->errstr = ' . $source_dbh->errstr . "\n" a +nd print '$source_dbh->err = ' . $source_dbh->err . "\n" and print '$! = ' . $! . "\n" and exit 1 }; print "Completed create table at ". get_date() ." Rows Created = [ +$rows]\n"; #if(defined $rows){ # print sample_table_log "Completed create table at ". get_date +() ." Rows Created = [$rows]\n"; #} #else { # print sample_table_log "\nCannot run $ctas_sql \n". $source_d +bh->errstr; # update_sample_table_driver_tb($t_owner,$t_name,'FAILED'); # exit 1; #} } ###################################################################### +############### # Get Date + # ###################################################################### +############### sub get_date { # Needed an easy way to get the system date. my $tmp_date= `/usr/bin/date "+%D %T"`; chomp($tmp_date); return $tmp_date; }
Strange SSH Behavior via system or exec
1 direct reply — Read more / Contribute
by cmv
on Sep 18, 2014 at 10:57
    Hi Monks-

    I can't explain this and need guidance from wiser minds - please help.

    Here’s how to reproduce:

    1.) Setup ssh public/private keys so that this unix shell command works without you having to enter a password:

    $ ssh usr@remotehost date

    2.) Run these command from your unix shell prompt - why does one FAIL (ask for password), while others don’t?

    $ perl -e 'system("ssh usr\@remotehost date”)’ # works $ perl -e 'system("ssh -l usr remotehost date")’ # works $ perl -e 'system("ssh", "usr\@remotehost", "date”)’ # works $ perl -e 'system("ssh", "-l usr", "remotehost", "date”)’ # FAILS
    You can replace system with exec and get the same result.

    Thanks

    -Craig

Cannot get enable> mode to work
2 direct replies — Read more / Contribute
by ArifS
on Sep 18, 2014 at 09:48
    I have a long script that is getting stuck while handling the > (enable) mode.
    I am trying to authenticate in the following two senarios-

    1)
    username:
    password:
    Device>

    1st scenario- getting stuck at Device>.

    2)
    Device>
    Same for the 2nd scenario stuck at Device>.

    use warnings; use Net::Telnet; my $Telnet = new Net::Telnet; my $InHandle = $Telnet->input_log("input.txt"); my $OutHandle = $Telnet->output_log("output.txt"); my $prmpt = '/[\w().-]*[\$#>:.]\s?(?:\(>\))?\s*$/'; $host="172.16.1.1"; $username = "user"; $password = "pass"; $enpwd = "enable"; my $telnet = Net::Telnet->new( Host => $host, Input_log => "input.log", Output_log => "output.log", Dump_Log => "dump.log", Timeout => 10); # provide host address $telnet->open("$host"); print "\n\n Connecting to $host\n"; # authentication @out = $telnet->waitfor('/Username: $/i') || next; $telnet->print($username); print "@out\n"; # for tshoot only @out = $telnet->waitfor('/Password: $/i') || next; $telnet->print($password); print "@out\n"; # for tshoot only # if enable, send "enable" and enable-pwd unless ($telnet->waitfor('/Username: $/i' | '/#/i')) { #$telnet->waitfor('/>/'); @out = $telnet->print('enable'); print "@out\n"; # for tshoot only @out = $telnet->print($enpwd); print "@out\n"; # for tshoot only } print "username, password, & enable mode authentication accepted-\n"; $telnet->close;
    Output:
    Connecting to 172.16.1.1 1 1 pattern match timed-out at c:\temp\dirB2D.tmp\testing 3.pl line 35 Press any key to continue . . . Connecting to 172.16.1.2 pattern match timed-out at c:\temp\dirEDA1.tmp\testing 3.pl line 26 Press any key to continue . . .
    I get the username and password passes thru in Scenario 1 but gets stuck in enable. Scenario 2 with .1.2 it doesn't like @out = $telnet->waitfor('/Username: $/i').
    Please help!

    Updated: code
Perl Newbie
2 direct replies — Read more / Contribute
by MaKha
on Sep 18, 2014 at 09:32

    What would the below code snippet mean?

    my ($_configParam, $_paramValue) = split(/\s*=\s*/, $_, 2); $configParamHash{$_configParam} = $_paramValue;
How to convert between decimal and binary for negative numbers?
2 direct replies — Read more / Contribute
by thanos1983
on Sep 18, 2014 at 09:10

    Hello Monks,

    I am trying to convert decimals to binary and binary to decimals. By using pack and unpack I can convert all positive numbers, in case that a number is negative the process needs to be changed.

    Sample of working code demonstrating the problem:

    #!/usr/bin/perl use strict; use warnings; my $possitive = 3; my $negative = -3; print "My possitive decimal: ".$possitive."\n"; print "My negative decimal: ".$negative."\n"; my $possitive_b = dec2bin($possitive,8); my $negative_b = dec2bin($negative,8); print "Possitive binary: ".$possitive_b."\n"; print "Negative binary: ".$negative_b."\n"; my $possitive_d = bin2dec($possitive_b); my $negative_d = bin2dec($negative_b); print "Possitive_binary back to decimal: ".$possitive_d."\n"; print "Negative_binary back to decimal: ".$negative_d."\n"; sub dec2bin { my $bits = shift; my $possition = shift; my $str = unpack("B32", pack("N", $bits)); $str = substr $str, -$possition; return $str; } sub bin2dec { return unpack("N", pack("B32", substr("0" x 32 . shift, -32))); } __END__ My possitive decimal: 3 My negative decimal: -3 Possitive binary: 00000011 Negative binary: 11111101 Possitive_binary back to decimal: 3 Negative_binary back to decimal: 253

    As we can see the negative -3 became 253.

    So is there a way to convert the negative decimals to binary and back to decimal?

    Seeking for Perl wisdom...on the process of learning...not there...yet!
Argument "CLOCK_REALTIME" isn't numeric in subroutine entry
1 direct reply — Read more / Contribute
by thanos1983
on Sep 18, 2014 at 07:15

    Hello Monks,

    Although that this question should have a simple answer I can not understand where I am going wrong. I am using a Linux OS and I executing the following part of code:

    #!/usr/bin/perl use strict; use warnings; use Time::HiRes qw( clock_gettime clock_getres ); my $realtime = clock_gettime('CLOCK_REALTIME'); my $resolution = clock_getres('CLOCK_REALTIME'); print "Realtime: ".$realtime."\n"; print "Resolution: ".$resolution."\n";

    I am getting this error:

    Argument "CLOCK_REALTIME" isn't numeric in subroutine entry at test.pl + line 6. Argument "CLOCK_REALTIME" isn't numeric in subroutine entry at test.pl + line 7. Realtime: 1411038919.69833 Resolution: 1e-09

    According to Time::HiRes the syntax should not include the single quotes and it should be modified accordingly:

    #!/usr/bin/perl use strict; use warnings; use Time::HiRes qw( clock_gettime clock_getres ); my $realtime = clock_gettime(CLOCK_REALTIME); my $resolution = clock_getres(CLOCK_REALTIME); print "Realtime: ".$realtime."\n"; print "Resolution: ".$resolution."\n";

    But I get the following error when I execute the code:

    Bareword "CLOCK_REALTIME" not allowed while "strict subs" in use at te +st.pl line 6. Bareword "CLOCK_REALTIME" not allowed while "strict subs" in use at te +st.pl line 7. Execution of test.pl aborted due to compilation errors.

    Any ideas why I am getting this error on both cases?

    Thank you in advance for your time and effort to assist me.

    Seeking for Perl wisdom...on the process of learning...not there...yet!

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 studying the Monastery: (7)
    As of 2014-09-19 02:36 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      How do you remember the number of days in each month?











      Results (129 votes), past polls