Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid

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
Perl 2 Excel
2 direct replies — Read more / Contribute
by newperlbie
on Aug 21, 2018 at 07:55
    Hi All, Thanks for the help on my previous perl to HTML query. Now,I am writing to an excel file and I have this code
    my $workbook = Spreadsheet::WriteExcel->new("output.xls"); my $worksheet = $workbook->add_worksheet("overview"); my $colCount = 0; my $rowCount = 0; open my $tf, "output.txt" or die "Cannot open file"; while(my $line = <$tf>) { if ( $line =~ /.*versions are SAME.*/) { my $header1 = $workbook->addformat(bold => 0, color => 'green', size => 10, merge => 0, ); $worksheet->set_column($colCount, $colCount, 30); print $line; #this is a dummy line $worksheet->write($rowCount,$colCount,$line,$header1); $rowCount++; } }
    All the lines from the text file are written to the excel but after a few lines(random) the coloring stops.The next lines are just written in black. What is my mistake?
PERL soap not well-formed (invalid token)
1 direct reply — Read more / Contribute
by kanewilliam7777
on Aug 21, 2018 at 07:22

    I have created WSDL file connect the file with PERL soap method. After the exection i get the below error message

    "not well-formed (invalid token) at line 1, column 1, byte 1 at /usr/lib/x86_64-linux-gnu/perl5/5.26/XML/ line 187." .

    Please let me know have to fix the issue.
    #!/usr/bin/perl -w #use SOAP::Lite +trace => ‘debug’; use SOAP::Lite; my $client = SOAP::Lite ->service('http://localhost/soap/perl/marketplace.wsdl'); my $result = $client->login( 'test_user', 'test_password' ); #~ my $result = $client->sayHello(''); print $result;
    #!/usr/bin/perl function login( $login, $password ) { return $login; } function doFilter( $params ) { return "some string"; }
    <?xml version="1.0" encoding="UTF-8"?> <definitions name="Marketplace" targetNamespace="urn:Marketplace" xmlns:tns="urn:Marketplace" xmlns:soap="" xmlns:xsd="" xmlns:soapenc="" xmlns:wsdl="" xmlns=""> <message name="LoginRequest"> <part name="login" type="xsd:string"/> <part name="password" type="xsd:string"/> </message> <message name="LoginResponse"> <part name="result" type="xsd:string"/> </message> <portType name="LoginPort"> <operation name="login"> <input message="tns:LoginRequest"/> <output message="tns:LoginResponse"/> </operation> </portType> <binding name="LoginBinding" type="tns:LoginPort"> <soap:binding style="rpc" transport="http://schemas.xmlsoap.or +g/soap/http"/> <operation name="login"> <soap:operation soapAction="urn:LoginAction"/> <input> <soap:body use="encoded" namespace="urn:Marketplace" e +ncodingStyle=""/> </input> <output> <soap:body use="encoded" namespace="urn:Marketplace" e +ncodingStyle=""/> </output> </operation> </binding> <service name="WSDLService"> <port name="LoginPort" binding="tns:LoginBinding"> <soap:address location="http://localhost/soap/perl/soap-se"/> </port> </service> </definitions>

    finally run the file return below error message.

    "not well-formed (invalid token) at line 1, column 1, byte 1 at /usr/lib/x86_64-linux-gnu/perl5/5.26/XML/ line 187." .

How to PRINT CGI html table to a PNG file
3 direct replies — Read more / Contribute
by theravadamonk
on Aug 21, 2018 at 07:03

    Dear Monks,

    I wrote a CGI code to get the load averga of my CentOS server. It gives 1 minute , 5 minutes and 15 minutes Load averages.

    I can see it via URL http://ipaddress/cgi-bin/Sys_Load.cgi

    Now, What I need is to INSERT this Sys_Load.cgi url to my home.cgi code. My ulitimate goal is to access URL http://ipaddress/cgi-bin/home.cgi.

    Then, Everything in home.cgi should be displayed.

    I have already dispalyed other codes with ""

    I can dispaly them since it PRINTS a png image to the browser.

    here's my home.cgi

    #!/usr/bin/perl use strict; use warnings; use CGI ':standard'; my $date = localtime(); print "Content-type: text/html\n\n"; print "<body bgcolor=\"#c0e0f9\">"; print qq!<br/><center> <h1>Home</h1> <h3>$date</h3> <img src = "root_partition.cgi"><br/><br/><br/> <img src = "var_partition.cgi"><br/><br/><br/> <img src = "stacked_Bar_graph.cgi"><br/><br/><br/> <img src = "topsenders_hbar.cgi"><br/><br/><br/> <img src = "toprecipients_hbar.cgi"><br/><br/><br/></center>!; print "</body>";

    Here's my Sys_Load.cgi code. I think If can PRINT CGI html table to a PNG file, It will be OK. I am right aint't I? How can I do it? seeking help...

    #!/usr/bin/perl use strict; use warnings; use CGI ':standard'; use Sys::Load qw/getload uptime/; print "Content-type: text/html\n\n"; print "<body bgcolor=\"#c0e0f9\">"; my ($one_m, $five_m, $fifteen_m) = (getload())[0,1,2]; print "<br/>"; print "Load Average \n"; print '<table style=width:20%><tr><th bgcolor=#FFDD00 height=25>1 Minu +te</th><th bgcolor=#FFDD00 height=25>5 Minutes</th><th bgcolor=#FFDD0 +0 height=25>15 Minutes</th></tr>'; print "\n <tr style=\"font-family:verdana\" bgcolor=\"#FFFFFF\"><t +d>$one_m</td><td>$five_m</td><td>$fifteen_m</td></tr>"; print '</table>'; print "</body>";
Imager : read image from scalar (not from file)
1 direct reply — Read more / Contribute
by bliako
on Aug 20, 2018 at 18:19

    Hi there, module Imager reads and operates on images. In my case I have the image in memory already (after downloading it with LWPL::UserAgent) and would like to auto-crop it before saving it to disk. It does not seem to me that Imager provides this option. Imager::Simple does provide it but then it does not seem to provide autocrop() (which is implemented in Imager::Filter::Autocrop).

    For example, this complains about not finding autocrop():

    use strict; use warnings; use Imager::Simple; use Imager::Filter::Autocrop; my $imgdata = undef; open(IN, '<', 'example.jpg'); binmode(IN); { local $/ = undef; $imgdata = <IN> } close(IN); my $img = Imager::Simple->new(); $img->read(\$imgdata) or die "read: ".$img->errstr(); $img->autocrop(fuzz=>20) or die "autocrop: ".$img->errstr(); $img->write('out.jpg') or die "writing: ".$img->errstr();

    As a possible workaround, I thought I can register a reader using Imager's register_reader() but that was a long shot as I have the suspicion that one needs to decode the image residing in the scalar first... The code below fails because it still thinks $img is a filename (after registering a reader):

    use Imager; use Imager::Filter::Autocrop; my $imgdata = undef; open(IN, '<', 'example.jpg'); binmode(IN); { local $/ = undef; $imgdata = <IN> } close(IN); my $img = Imager->new(); $img->register_reader( type => 'scalar', single => sub { my ($im, $io, %hsh) = @_; $im->{IMG} = $io; return $im }, ) or die "register_reader: ".$img->errstr(); $img->read(type=>'scalar', file=>$imgdata) or die "read: ".$img->errst +r(); $img->autocrop(fuzz=>20) or die "autocrop: ".$img->errstr(); $img->write(file=>'out.jpg') or die "writing: ".$img->errstr();

    So, can anyone suggest a way to apply sensible and flexible (e.g. with a fuzziness factor etc.) auto-crop to an image already in memory? It does not need to be using Imager.

    I am talking about several thousand images here and I would hate to download them, save them to file, read them back to memory, auto-crop them and save them back to disk... That would be awful. Thanks, bliako

Debugging a POST that won't
2 direct replies — Read more / Contribute
by BernieC
on Aug 20, 2018 at 13:23
    I can't get a POST to work and I can't figure out why not. I can get and post well enough to get authenticated and otherwise navigate around the site, but this post just won't work. I've tried comparing my _request with the request I see in a WebDeveloper capture of submitting the same POST and as far as I can tell they are identical. I submit all of the same fields that Firefox does {collected from the WD capture - I did't trust that if I just looked at the "view page source" I wouldn't miss one}. The site doesn't give me a hint as to what's wrong, of course, I just get to the appropriate reponse page but with my 'submit' having not happened. Any ideas/tricks for how to figure out what's wrong? It's https:// so I can't go beyond WD to do sniffing of the of actual network data. There aren't any redirects or other oddities: WD says when I click "submit" firefox does a single POST that, as I mentioned, looks pretty much identical to my UserAgeng POST. I have the security tokens correct {it uses two: a security_token POST paramter and a csrf cookie}. I don't know where else to look or what else to try. <p<Just to make it more concrete, the code involved is dead simple:
    @fields = (current_step => "New" , next_step => "NewFinal" , [etc ... all the identical fields from both scraping the HTML and lo +oking at WD] ); ); unshift @fields, csrf_token => $csrf_token if $csrf_token ; unshift @fields, security_key => $security_key if $security_key ; $res = $ua->request(POST $_[0], \ @fields) ;
    What should I try next?
Find and replace based on unique identifier
2 direct replies — Read more / Contribute
by oryan
on Aug 20, 2018 at 13:04

    I need to find and replace 2 lines of code related to culverts in a model text file. I have a model with all the lines in the right order with the OLD culvert values, and another text file with the NEW culvert values but in the wrong order. What the script does currently:

    1. In the model, finds line beginning with text "Connection Culv". This is the line of text I need to replace.
    2. Finds the next line after "Connection Culv" that starts with "Conn Culvert Barrel" - this is the unique identifier for the replacement.
    3. Pulls new values of "Connection Culv" from text file and replaces them in model.
    4. Repeats for all instances of Connection Culv and then saves new file.

    Instead of ONLY replacing the line that begins with "Connection Culv" I need it to replace that line and the following line ( 111 111, 222 222, etc), but I can't get it to work.


    Connection Culv=This is Line1 111 111 Conn Culvert Barrel=Culvert1 * Connection Culv=This is Line2 222 222 Conn Culvert Barrel=Culvert2 * Connection Culv=This is Line3 333 333 Conn Culvert Barrel=Culvert3 *

    Connection Culv=This is Line3 - New text here 333 333 This should be new too Conn Culvert Barrel=Culvert3 * Connection Culv=This is Line1 - New text here 111 111 This should be new too Conn Culvert Barrel=Culvert1 * Connection Culv=This is Line2 - New text here 222 222 This should be new too Conn Culvert Barrel=Culvert2 *

    Connection Culv=This is Line1 - New text here 111 111 Conn Culvert Barrel=Culvert1 * Connection Culv=This is Line2 - New text here 222 222 Conn Culvert Barrel=Culvert2 * Connection Culv=This is Line3 - New text here 333 333 Conn Culvert Barrel=Culvert3 *

    Connection Culv=This is Line1 - New text here 111 111 This should be new too Conn Culvert Barrel=Culvert1 * Connection Culv=This is Line2 - New text here 222 222 This should be new too Conn Culvert Barrel=Culvert2 * Connection Culv=This is Line3 - New text here 333 333 This should be new too Conn Culvert Barrel=Culvert3 *

    There are hundreds of these replacements that need to be made throughout the model. I feel like this should be simple, but nothing has worked. Here is the code I have currently that works for replacing the single line "Connection Culv" but not the following line. Any help is appreciated. Thanks.

    # HEC-RAS Replacement Perl Script # This will find and replace values in the HEC-RAS geometry file for m +odified culvet barrels. The process is: # 1. In existing model file (HECRAS_Ex.txt) find where there is a " +Connection Culv" (this is the line that needs to be replaced) # 2. It then down for the next Conn Culvert Barrel line (this is th +e unique identifier) # 3. It then takes from the new culvert file (culvNEW.txt) the new +"Connection Culv" line and replaces it in the existing HECRAS_Ex.txt +file. # 4. Repeats for all and then saves out Output_HECRAS.txt # Nomenclature for running Perl Script: # C:\MyDir> perl culvNEW.txt HECRAS_Ex.txt OutPut_H +ECRAS.txt # Read Existing HEC-RAS Geometry File (HECRAS_Ex) with Old Culvert Con +nection Attributes open (TEMPLATE, @ARGV[1]) or die; @HECRAS_Ex = <TEMPLATE>; close TEMPLATE; # Read New Culvert Data File (culvNEW) with new Connection culvert Att +ributes open (TEMPLATE, @ARGV[0]) or die; @culvNEW = <TEMPLATE>; close TEMPLATE; for ($i=0; $i<@HECRAS_Ex; $i++) { # only check lines starting with "Connection Culv" in the HECRAS_Ex fi +le if ($HECRAS_Ex[$i] =~ /^Connection Culv/) { #print $HECRAS_Ex[$i]; #look for Connection Culv backwards $iback=$i-1; while ($HECRAS_Ex[$iback] !~ /^Conn Culvert Barrel/) { $iback=$iback+1; } $local0=$HECRAS_Ex[$iback]; chomp($local0); # print $HECRAS_Ex[$iback]; for ($j=0; $j<@culvNEW; $j++) { # for ($j=0; $j<1; $j++) { $local = $culvNEW[$j]; chomp($local); # print $local; # Remove the trailing new line # chomp $local; # print ($local eq $HECRAS_Ex[$iback]); if ($local =~ /^$local0/) { # print "match"; $jforward=$j-1; while ($culvNEW[$jforward] !~ /^Connection Culv/) { $jforward=$jforward-1; } # print $culvNEW[$jforward]; # Perform substitutions of LG card $HECRAS_Ex[$i]=$culvNEW[$jforward]; # print $HECRAS_Ex[$i]; } } } } #write out the Geometry File based on the HECRAS_Ex file structure and + the new values in the culvNEW file open (OUT, ">" . @ARGV[2]) or die; # Write output print OUT @HECRAS_Ex; # Close OUT close OUT;
Write large array to file, very slow
4 direct replies — Read more / Contribute
by junebob
on Aug 20, 2018 at 10:04

    Hi, I have written a bit of perl, which is performing very slowly, so I'm hoping to get some advice here

    The script takes in any number of files, where all files have the format that each line starts with a 10 hexit hex count, followed by anything. The count on each line is always greater than the count value on the previous line. The task is to merge all the input files in to one file, in order. The input files can be quite large, 3GB or so. After a bit of googling I decided to put all the input files in an array, and put the result in a new array and finally write out the new array to a file. Mainly because I have access to machines with lots of RAM, so I thought if it's all chucked in to memory it'll be faster, and then I just dump the end result in to a file.

    It hasn't really worked out as I expected. The script got to the point where the final array is complete and it's starting to write out to the file after about an hour or so. However, just the writing to a file is taking many hours!

    Any suggestions as to how to improve my script? Thanks!

    #!/bin/env perl use strict; use warnings; use List::Util qw(min max); use Math::BigInt; my @filenames = @ARGV; #Define empty hash. This will be a hash of all the filenames. Within t +he hash each filename points to an array containing the entire conten +ts of the file, and an array of timestamps. my %all_files=(); #>32 hex to dec function sub hex2dec { my $hex = shift; return Math::BigInt->from_hex("0x$hex"); } #For each file on the command line, create a new hash entry indexed by + the filename. Each entry is an array containing the contents of the +file. foreach my $filename (@filenames) { open(my $handle, "<", "$filename") or die "Failed to open file $file +name: $!\n"; while(<$handle>) { chomp; my $fullline = $_; if($fullline =~ m/(\w+).*/) { #Store contents of line my $timestamp = $1; push @{$all_files{$filename}}, $fullline; push @{$all_files{"${filename}.timestamp"}}, $timestamp; } else { print "Unexpected line format: $fullline in $filename\n"; exit; } } close $handle; $all_files{"${filename}.neof"} = 1; } my $neofs = 1; my @minarray = (); my $min = 0; my $storeline = ""; my @mergedlogs = (); my $matchmin=0; my $line=0; while ($neofs == 1) { print "$line\n"; $line++; $neofs = 0; #First find the lowest count foreach my $filename (@filenames) { print "@{$all_files{\"${filename}.timestamp\"}}[0]\n"; my $tmpdec=hex2dec(@{$all_files{"${filename}.timestamp"}}[0]); print "$tmpdec\n"; push @minarray, hex2dec(@{$all_files{"${filename}.timestamp"}}[0]) +; } $min = min @minarray; @minarray = (); #For each file matching the lowest count, shift out the current line foreach my $filename (@filenames) { print "$filename $min"; $matchmin=0; if(hex2dec(@{$all_files{"${filename}.timestamp"}}[0]) == $min && $ +all_files{"${filename}.neof"} == 1) { $matchmin=1; $storeline = shift @{$all_files{$filename}}; shift @{$all_files{"${filename}.timestamp"}}; #Check if array is empty (i.e. file completed) if ( ! @{$all_files{$filename}}) { #If so, set not end of file to 0 $all_files{"${filename}.neof"} = 0; #Force count value to max so that it loses all future min batt +les push @{$all_files{"${filename}.timestamp"}}, "10000000000"; } #Push the line to the merged file. push @mergedlogs, "$storeline $filename"; } $neofs = $neofs || $all_files{"${filename}.neof"}; } } unlink "mergedlogs.txt"; foreach (@mergedlogs) { open FH, ">>mergedlogs.txt" or die "can't open mergedlogs.txt: $!"; print FH "$_\n"; close FH }
GetOptions Help Needed
1 direct reply — Read more / Contribute
by MysticElaine
on Aug 20, 2018 at 09:19

    Hello. I can't seem to figure out how to get this code to work despite lots of Googling. Every time I think I wrap my head around it, I realize I'm spinning in circles :( I have a script that I need to modify. It currently has the ability to take in multiple options in which it is then going to update a database table. I need to be able to instead of having multiple variables written in the command line, I have just one option entered which will still do what it was doing before, but then some more stuff :)
    For example, I currently run the command

    liupdate B-P-2C544BX --type summary -c "setting status summary again" --status closed

    and the result is:

    open siebel qa Tickets DelegatedOwner Abstract B-P-2C544BX George someone requests Reboot on W.X.Y.Z. ---------- Issue: B-P-2C544BX IssueStatus: Open->Closed ActivityType: Status Summary ActivityAbstract: "update" ActivityComments: "setting status summary again" y/n/YES/NO? (YES/NO => y/n to all tickets) : n

    Now, I want to be able to do this in one go by running the command

    liupdate B-P-2C544BX --decon

    The logic behind this is that the --decon option will call up a subroutine that will:
    i) Sends email to users
    ii) Change Status Summary
    iii) Change the ToDo instructions
    iv) Change status of the ticket

    I am very new to coding, and I can't seem to be able to get the information combined to update the table. I have been able to get one part (status update) or the other (summary update) to work, but not both simultaneously. I have also tried to get rid of most of the functions and just flat out state in the subroutine that "Status" = "Closed," but I couldn't get the variables to still work in the main call of the script. I was hoping that just making the variables the values I wanted would work as the subroutine needs to be able to add two rows to the database table (one for summary and one for todo), and currently, the script can only do one. Below is the script

    #!/usr/bin/perl + + use strict; use NIE::Siebel; use NIE::MyWS; use NIE::Issue; use NIE::Utils; use Term::UI; use Term::ReadLine; use Getopt::Long; use Pod::Usage; use Data::Dumper; + + # this will try and extract siebel ids. Once we have a potential list, + we will # check with standard NIE utilitles my $test=" 9 asd 3 ad 23 bb 234 B-4-Q0KEI - Data centeer id B-4-Q0KEI- Data centeer id B-4-Q0KEI# datacenter id B-P-2B9NE3K - ticket id B-P-2B9NE18 - ticket id B-P-2B9NE69- ticket id B-P-2B9IUC7XX- ticket id B-M-2CDHQV4- ticket id B-P-2B3O6BE-ticket id- ticket id B-M-2CRYYTD\$ - orderid "; my $sid_regexp = qr/([[:alpha:]]-[[:alnum:]]-\w+)/; my $ip_regexp = qr/\b(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3} +(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\b/; my $qa = undef; my $debug = undef; my $verbose = undef; my $live = 1; #undef; # default to live (really update) but can t +urn this off. my $yes_just_once = undef; # Yes to one ticket my $abstract = "Status Change"; my $activity_type = undef; my $comments = undef; my $prompt_to_update = 1; my $issue_status = undef; my $extract_ids_from_comments = 1; # by default we extract ids from th +e text entered. my $extract_ips_from_comments = 1; # extract ips as well to look up ti +ckets my $login = uc($ENV{USER}); my @issues; my @filters = $ENV{NIE_ISSUE_UPDATE_FILTER} || "and delegated_owner_lo +gin = '$login'"; my (%options) = ( "debug!" => sub { NIE::Issue->debug($debug) if ($debug); $debug++; }, "verbose!" => sub { NIE::Issue->verbose($verbose) if ($verbose); $verbose++; }, "qa!" => sub { $qa = 1; }, "abstract|a=s" => \$abstract, "comment|c=s" => \$comments, "dry-run|n" => sub { $live = undef }, "no-extract-ids" => sub { $extract_ids_from_comments = undef }, "extract-ids" => sub { $extract_ids_from_comments = 1 }, "no-extract-ids" => sub { $extract_ids_from_comments = 0 }, "extract-ips" => sub { $extract_ips_from_comments = 1 }, "no-extract-ips" => sub { $extract_ips_from_comments = 0 }, "ips" => sub { $extract_ips_from_comments = 1 }, "type|t=s" => sub { shift; $activity_type = to_activity_type($ +_[0]); }, "status=s" => sub { shift; $issue_status = to_issue_status($_[ +0]); }, "issue-status=s" => sub {$issue_status = to_issue_status('closed'); +}, "help!" => sub { die_usage(1); }, "yes|y!" => \$yes_just_once, "YES!" => sub { $prompt_to_update = undef; }, "decon" => \&decon_server, ); sub die_usage { my ($a) = @_; if ($a) { pod2usage(-exitstatus => 0, -verbose => 2); exit; } else { pod2usage(2); exit; } } + + sub usage (;$) { # Print any arguments if (@_) { print join("\n", @_), "\n\n"; } die_usage(); exit(@_ ? 1 : 0); } sub extract_sids { # obscure uniq expression do { my %seen; grep { !$seen{$_}++ } +@data }; my (@ids) = do { my %seen; grep { !$seen{$_}++ } ($_[0] =~ m/$s +id_regexp/mg)}; return @ids; } sub extract_ips { # obscure uniq expression do { my %seen; grep { !$seen{$_}++ } +@data }; my (@ids) = do { my %seen; grep { !$seen{$_}++ } ($_[0] =~ m/$i +p_regexp/mg)}; return @ids; } # handle short hand for resolutions + + my %ACTIVITY_TYPES = ( # 'followup' => 'Follow Up', 'todo' => 'Todo', 'resolution' => 'Resolution', 'statussummary' => 'Status Summary', 'summary' => 'Status Summary', ); my %ISSUE_STATUS = ( 'open' => 'Open', 'closed' => 'Closed', 'cancelled' => 'FOOBAR', 'pending' => 'Pending', 'scheduled' => 'Scheduled', ); sub to_activity_type { my $tag = shift; return alias_to_string(\%ACTIVITY_TYPES, "activity", $tag); } sub to_issue_status { my $tag = shift; return alias_to_string(\%ISSUE_STATUS, "issue status", $tag); } sub decon_server { my $time = time(); my $future_time = $time + (30*24*60*60); #30 days with 24hrs in + a day with 60 min in an hour with 60 sec in a min my ($second, $minute, $hour, $day, $month, $year, $dayOfWeek, $da +yOfYear, $daylightSavings) = localtime($time); my ($fsecond, $fminute, $fhour, $fday, $fmonth, $fyear, $fdayOf +Week, $fdayOfYear, $fdaylightSavings) = localtime($future_time); $year += 1900; $fyear += 1900; my @month_name = qw(Jan Feb Mar Apr May June July Aug Sept Oct +Nov Dec); my $decon_date = "$month_name[$fmonth]/$fday/$fyear"; return $decon_date; #print $decon_date; #main ($options{status}='closed'); #$issue_status = to_issue_status("closed"); #$comments = "Decon on $decon_date"; #$activity_type = to_activity_type("summary"); #$activity_type = "summary"; #$status = "closed"; } sub alias_to_string { my $ALIASES = shift; my $type = shift; my $tag = shift; my @matches = grep(/^${tag}/i, sort(keys(%$ALIASES))); + + # if we have 'Other' and 'Other H&E..' then we can't possibly h +andle the # match if we just enter 'Other'. So, if we have an ambiguious +match, try an exact match. @matches = grep(/^$tag$/i, sort(keys(%$ALIASES))) if (! (@matches + == 1)); if (@matches == 1) { return $ALIASES->{$matches[0]}; } elsif (@matches) { # More than one usage("Ambiguous action abbreviation '$tag' which has multiple + matches:" . ' ' . join(', ', @matches)); # NOTREACHED } else { @matches = grep(/^$tag/i, sort(values(%$ALIASES))); return $matches[0] if (@matches == 1); usage("Unknown or unsupported $type type: '$tag'"); + + #return $tag; # if all else fails, assume it is a type we d +on't know # about but really exists. # NOTREACHED } } # # modify how lookups work in the Module. # sub replace_lookup { my $lu = shift; my @lookups = (); for my $i (@NIE::Issue::lookups) { if ($lu->{name} eq $i->{name}) { push @lookups, $lu; } else { push @lookups, $i; } } @NIE::Issue::lookups = @lookups; } replace_lookup({ 'name' => 'issue_id', 'type' =>'object', 'func' =>sub { my ($id) = @_; return is_issue_id($id) }, 'query' => "select issue_id from cmn_int.ak_issue where issue +_id in (\$refs)", }, ); main: { my $dbh = undef; my $term = Term::ReadLine->new("brand"); die_usage() if (!GetOptions(%options)); NIE::Object->qa(1) if ($qa); if ($qa) { $dbh = openSiebelqa(); printf "open siebel qa\n"; } else { $dbh = openSiebel(); $NIE::MyWS::test_only = 0; } my @stuff_to_search = (); # So, if we specify the tickets from the command line, assume # that is more relevant than extraction from comments. if (@ARGV) { push @stuff_to_search, @ARGV; } else { # Extract everything that looks lke a siebel id. my @siebel_ids = (); push @siebel_ids, extract_sids($comments) if ($extract_ids_ +from_comments); # Use standard NIE::Util functions to classify tickets. push @stuff_to_search, map {(is_issue_id($_))?$_:()} @siebe +l_ids; push @stuff_to_search, map {(is_order_id($_))?$_:()} @siebe +l_ids; # search for ips if requested. push @stuff_to_search, extract_ips($comments) if ($extract_ +ips_from_comments); } my %search_opts = ('filter' => \@filters); if (! @ARGV) { $search_opts{lookups} = ['order_id','issue_id','ip_address']; } my @issues = NIE::Issue->search(\%search_opts, @stuff_to_search +); if (@issues == 0) { printf STDERR "No ticket reference found.\n"; exit 1; } printf "Tickets DelegatedOwner Abstract\n%s\n\n", join("\n", map{sprintf "%-13s %-14s %s", $_->issue_id, $_->delegated_owner_login, $_->abstract} @issues); for my $i (@issues) { my $intid = undef; my $verbage = undef; $verbage .= sprintf "----------\nIssue: %s\n", $i->issue_id + ; $verbage .= sprintf "IssueStatus: %s->%s\n", $i->status, $i +ssue_status if ($issue_status); $verbage .= sprintf "ActivityType: %s\nActivityAbstract: \" +%s\"\nActivityComments:\n\"%s\"\n", $activity_type, $abstract, $comme +nts if ($activity_type); if ($prompt_to_update && !$yes_just_once) { my $reply = $term->get_reply( prompt => "y/n/YES/NO? (YES/NO => y/n to all ticke +ts)", allow => ['y','n','YES','NO'], print_me => $verbage); next if ($reply eq 'n'); last if ($reply eq 'NO'); $prompt_to_update = undef if ($reply eq 'YES'); } $yes_just_once = 0 if ($yes_just_once); printf "Updating %s\n", $i->issue_id; if ($live) { $intid = addFollowup($i->issue_id, $abstract, $comments, undef, undef, undef, undef, $activity_type); } if ($issue_status) { if ($live && $i->status ne $issue_status) { $intid = UpdateNoccSRTicket( 'SRId' => $i->issue_id, 'Status' => $issue_status ); } } } }

    Thanks for any help :)

Active perl Perlapp problem
3 direct replies — Read more / Contribute
by harryC
on Aug 20, 2018 at 05:56
    Hi This code
    #!/usr/bin/perl -w use strict; use DateTime::Format::ISO8601; use DateTime::Format::Strptime; use Data::Dumper; my $di = DateTime::Format::ISO8601->parse_datetime('2018-08-20T06:43:5 +0.330Z'); my $dv = DateTime::Format::ISO8601->parse_datetime('2018-08-20T06:46:5 +6.147Z'); my $delta = $dv - $di; print Dumper $delta;
    works fine in perl interpreter 5.16
    but when i make a binairy with PerlApp it gives me following error


    Thanks for your Help
    Harry C
Perl 2 HTML
4 direct replies — Read more / Contribute
by newperlbie
on Aug 20, 2018 at 05:30
    Hi Everyone, I have a very very basic question.Please assure my thoughts with your answers. I have a perl script which reads a csv file,and 2 text files and gives some output.My requirements :

    1.I need a simple HTML page to take these files as input.(this needs to be static right?because I need to share this URL to others)

    2.Then my perl script should be executed.

    3.Finally the outut,again I need to display in the HTML page.

    What is the simplest way to do this? can I get this done without a web server? if so how? Please help me with a starting tip, so that I get through


Add your question
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.
  • 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 scrutinizing the Monastery: (7)
    As of 2018-08-21 15:22 GMT
    Find Nodes?
      Voting Booth?
      Asked to put a square peg in a round hole, I would:

      Results (200 votes). Check out past polls.