my $Parser = new MIME::Parser;
my $entity = $Parser->parse_data( $body );
my #parts = $entity->parts;
for $part(#parts){
my $type=$part->mime_type;
my $bhandle=$part->bodyhandle;
$header = $part->head();
$content_disp = $header->get('Content-Disposition');
if ($type =~ /text/i){
$bodydata = "";
if (my $io = $part->open("r")) {
while (defined($_ = $io->getline)) {
$bodydata .= $_;
}
$io->close;
print $bodydata;
}
}
}
I think you're looking for the recommended_filename method:
$header = $part->head();
$filename = $header->recommended_filename;
Be sure to check the return value for sanity. Note that it can also be undef.
Related
I was not able to parse the xml data properly. I need your help.
**Code**
#!usr/bin/perl
use strict;
use warnings;
open(FILEHANDLE, "data.xml")|| die "Can't open";
my #line;
my #affi;
my #lines;
my $ct =1 ;
print "Enter the start position:-";
my $start= <STDIN>;
print "Enter the end position:-";
my $end = <STDIN>;
print "Processing your data...\n";
my $i =0;
my $t =0;
while(<FILEHANDLE>)
{
if($ct>$end)
{
close(FILEHANDLE);
exit;
}
if($ct>=$start)
{
$lines[$t] = $_;
$t++;
}
if($ct == $end)
{
my $i = 0;
my $j = 0;
my #last;
my #first;
my $l = #lines;
my $s = 0;
while($j<$l)
{
if ($lines[$j] =~m/#/)
{
$line[$i] = $lines[$j];
$u = $j-3;
$first[$i]=$lines[$s];
$s--;
$last[$i] = $lines[$u];
#$j = $j+3;
#$last[$i]= $lines[$j];
#$j++;
#$first[$i] = $lines[$j];
$i++;
}
$j++;
}
my $k = 0;
foreach(#line)
{
$line[$k] =~ s/<.*>(.* )(.*#.*)<.*>/$2/;
$affi[$k] = $1;
$line[$k] = $2;
$line[$k] =~ s/\.$//;
$k++;
}
my $u = 0;
foreach(#first)
{
$first[$u] =~s/<.*>(.*)<.*>/$1/;
$first[$u]=$1;
$u++;
}
my $m = 0;
foreach(#last)
{
$last[$m] =~s/<.*>(.*)<.*>/$1/;
$last[$m] = $1;
$m++;
}
my $q=#line;
open(FILE,">Hayathi.txt")|| die "can't open";
my $p;
for($p =0; $p<$q; $p++)
{
print FILE "$line[$p] $last[$p],$first[$p] $affi[$p]\n";
}
close(FILE);
}
$ct++;
}
This code should extract lastName firstName and affiliation from the data and should save in a text file.
I have tried the above code, but I was not able to get the firstName in the output.
I request you to please help me by correcting the code.
Thank you in advance.
You can take following code sample as basis of your code.
As no text xml sample data file provided the help is very limited based on data image.
Documentation: XML::LibXML
use strict;
use warnings;
use feature 'say';
use XML::LibXML;
my $file = 'europepmc.xml';
my $dom = XML::LibXML->load_xml(location => $file);
foreach my $node ($dom->findnodes('//result')) {
say 'NodeID: ', $node->{id};
say 'FirstName: ', $node->findvalue('./firstName');
say 'LastName: ', $node->findvalue('./lastName');
say '';
}
exit 0;
I have a file with following contents:
TIME
DATE TIME DAY
191227 055526 FRI
RC DEV SERVER
RC1 SERVER1
RC2 SERVER2
RC3 SERVER3
END
I am fetching argument values from this file, say if I pass DATE as an argument to the script I am getting corresponding value of the DATE. i.e., 191227
When I pass multiple arguments say DATE, DAY I should get values:
DATE=191227
DAY=FRI
But what I am getting here is:
DATE=191227
DAY=NULL
And if I pass RC as an argument I should get:
RC=RC1,RC2,RC3
The script looks below:
#!/usr/bin/perl
use strict;
use Data::Dumper;
print Dumper(\#ARGV);
foreach my $name(#ARGV){
print "NAME:$name\n";
my ($result, $start, $stop, $width) = "";
while(my $head = <STDIN>)
{
if( $head =~ (m/\b$name\b/g))
{
$start = (pos $head) - length($name);
$stop = (pos $head);
my $line = <STDIN>;
pos $head = $stop+1;
$head =~ (m/\b/g);
$width = (pos $head) - $start;
$result = substr($line,$start,$width);
}
}
$result =~ s/^\s*(.*?)\s*$/$1/;
print "$name=";
$result = "NULL" if ( $result eq "" );
print "$result\n";
}
Can someone please help me to get values if I pass multiple arguments also if suppose argument value have data in multiple lines it should be printed comma separated values (ex: for RC, RC=RC1,RC2,RC3).
Here is an example, assuming the input file is named file.txt and the values are starting at the same horizontal position as the keys:
package Main;
use feature qw(say);
use strict;
use warnings;
use Data::Dumper qw(Dumper);
my $self = Main->new(fn => 'file.txt', params => [#ARGV]);
$self->read_file();
$self->print_values();
sub read_file {
my ( $self ) = #_;
my $fn = $self->{fn};
open ( my $fh, '<', $fn ) or die "Could not open file '$fn': $!";
local $/ = ""; #Paragraph mode
my #blocks = <$fh>;
close $fh;
$self->{values} = {};
for my $block (#blocks) {
$self->parse_block( $block );
}
}
sub parse_block {
my ( $self, $block ) = #_;
my #lines = split /\n/, $block;
my $header = shift #lines;
my ($keys, $startpos) = $self->get_block_keys( $header );
for my $line ( #lines ) {
for my $key (#$keys) {
my $startpos = $startpos->{$key};
my $str = substr $line, $startpos;
my ( $value ) = $str =~ /^(\S+)/;
if ( defined $value ) {
push #{$self->{values}{$key}}, $value;
}
}
}
}
sub get_block_keys {
my ( $self, $header ) = #_;
my $values = $self->{values};
my #keys;
my %spos;
while ($header =~ /(\S+)/g) {
my $key = $1;
my $startpos = $-[1];
$spos{$key} = $startpos;
push #keys, $key;
}
for my $key (#keys) {
if ( !(exists $values->{$key}) ) {
$values->{$key} = [];
}
}
return (\#keys, \%spos);
}
sub new {
my ( $class, %args ) = #_;
return bless \%args, $class;
}
sub print_values {
my ( $self ) = #_;
my $values = $self->{values};
for my $key (#{$self->{params}}) {
my $value = "<NO VALUE FOUND>";
if ( exists $values->{$key} ) {
$value = join ",", #{$values->{$key}};
}
say "$key=$value";
}
}
Edit
If you want to read the file from STDIN instead, change the following part of the code:
# [...]
my $self = Main->new(params => [#ARGV]);
$self->read_file();
$self->print_values();
sub read_file {
my ( $self ) = #_;
local $/ = ""; #Paragraph mode
my #blocks = <STDIN>;
$self->{values} = {};
for my $block (#blocks) {
$self->parse_block( $block );
}
}
# [...]
I have tried to add a proxy server to the following perl script:
#!/usr/bin/perl
TO='list of email adresses here';
require "/usr/local/SCRIPTS/www-tools/service-name/jcode.pl";
use LWP::UserAgent;
$sendmail = '/usr/lib/sendmail -t -oi';
######################
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
$year = $year+1900;
$mon = $mon+1;
$MMDD = sprintf("%02d/%02d",$mon,$mday);
$HHMM = sprintf("%02d:%02d",$hour,$min);
$err = 0;
#Ph.1 WebAccess-1stServer(VIP)
#ret = &SiteAccess( 'http://IP:PORT/hostname/' ,
'http://IP:PORT/hostname/Login.do' );
if( $ret[0] != 200 || $ret[2] != 200 ){
$err = 1;
}
$body = &jcode::euc($ret[1]);
if( $body !~ m#<title>ServiceName<\/title># ){
$err = 2;
}
$title = &jcode::euc('<title>web$BO"7H(J</title>');
$body = &jcode::euc($ret[3]);
if( $body !~ m#$title# ){
$err = 3;
}
&MailSend('Web') if( $err > 0 );
$err=0;
#Ph.2 WebAccess-2ndServer(Direct)
#ret = &SiteAccess( 'http://2ndServerIP:PORT/hostname/' ,
'http://2ndServerIP:PORT/hostname/Login.do' );
if( $ret[0] != 200 || $ret[2] != 200 ){
$err = 4;
}
$body = &jcode::euc($ret[1]);
if( $body !~ m#<title>ServiceName<\/title># ){
$err = 5;
}
$title = &jcode::euc('<title>web$BO"7H(J</title>');
$body = &jcode::euc($ret[3]);
if( $body !~ m#$title# ){
$err = 6;
}
&MailSend('Web2nd') if( $err > 0);
$err=0;
#Ph.3 POP
#ret = &SiteAccess( 'http://IP:PORT/hostname/' ,
'http://IP:PORT/hostname/Login.do' );
if( $ret[0] != 200 || $ret[2] != 200 ){
$err = 7;
}
$body = &jcode::euc($ret[1]);
if( $body !~ m#<title>ServiceName</title># ){
$err = 8;
}
$title = &jcode::euc('<title>TitleJapanese<(J</title>');
$body = &jcode::euc($ret[3]);
if( $body !~ m#$title# ){
$err = 9;
}
&MailSend('POP') if( $err > 0);
$err=0;
#Ph.4 Exchange(EWS)
#ret = &SiteAccess( 'http://IP:PORT/hostname/' ,
'http://IP:PORT/hostname/Login.do' );
if( $ret[0] != 200 || $ret[2] != 200 ){
$err = 10;
}
$body = &jcode::euc($ret[1]);
if( $body !~ m#<title>ServiceName</title># ){
$err = 11;
}
$title = &jcode::euc('<title>TitleJapanese<(J</title>');
$body = &jcode::euc($ret[3]);
if( $body !~ m#$title# ){
$err = 12;
}
&MailSend('Exchange-EWS') if( $err > 0);
$err=0;
sub SiteAccess{
my $url1 = shift;
my $url2 = shift;
# $ua,$req,$res;i
my #r;
if($url1 ne ''){
$ua = LWP::UserAgent->new;
$req = HTTP::Request->new(GET => $url1);
$res = $ua->request($req);
$r[0] = $res->code;
$r[1] = $res->content;
}
if($url2 ne ''){
$ua = LWP::UserAgent->new;
$res = $ua->post( $url2,
{
"c" => "don't knwo what that is",
"u" => "users ldap",
"p" => "password"
},
"Content-Type" => "application/x-www-form-urlencoded",
"User-Agent" => "DoCoMo/2.0 N901iS(c100;TB;W24H12;ser123445654654645;icc898114564645667716666f)");
$r[2] = $res->code;
$r[3] = $res->content;
}
return #r;
}
sub MailSend{
my $title = shift;
my $body;
my $from;
my #message;
#the following lines need another file name jcode to display properly. It just means error code or auth error.
$message[1] = &jcode::jis('[Web]$B%(%i!<%3!<%I(J');
$message[4] = &jcode::jis('[Web2nd]$B%(%i!<%3!<%I(J');
$message[7] = &jcode::jis('[POP]$B%(%i!<%3!<%I(J');
$message[10] = &jcode::jis('[EWS]$B%(%i!<%3!<%I(J');
$message[2] = &jcode::jis('[Web]$B%m%0%$%s2hLL(J');
$message[5] = &jcode::jis('[Web2nd]$B%m%0%$%s2hLL(J');
$message[8] = &jcode::jis('[POP]$B%m%0%$%s2hLL(J');
$message[11] = &jcode::jis('[EWS]$B%m%0%$%s2hLL(J');
$message[3] = &jcode::jis('[Web]auth$B%(%i!<(J');
$message[6] = &jcode::jis('[Web2nd]auth$B%(%i!<(J');
$message[9] = &jcode::jis('[POP]auth$B%(%i!<(J');
$message[12] = &jcode::jis('[EWS]auth$B%(%i!<(J');
$from = 'mail#abc.com';
$title = '['.$title.']cnct1 err';
# $title = $title.'['.$MMDD.$HHMM.']';
$body =<<END_OF_BODY;
To: $TO
Subject: $title
From: $from
ConnectOneCheck Error
Date : $MMDD $HHMM
ErrorStatus: $err
ErrorMsg : $message[$err]
END_OF_BODY
open(ML,"| $sendmail") || &error("Can't execute sendmail : $sendmail\n");
print ML $body;
close(ML);
}
So now here's the part where I tried to add the usage of a proxy. Most parts are commented out, except for the last function:
!/usr/bin/perl
TO='list of email adresses here';
require "/usr/local/SCRIPTS/www-tools/service-name/jcode.pl";
use LWP::UserAgent;
$sendmail = '/usr/lib/sendmail -t -oi';
######################
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
$year = $year+1900;
$mon = $mon+1;
$MMDD = sprintf("%02d/%02d",$mon,$mday);
$HHMM = sprintf("%02d:%02d",$hour,$min);
$err = 0;
The next part is commented out because it is not in use.
#ret = &SiteAccess( 'http://IP:PORT/hostname/' ,
'http://IP:PORT/hostname/Login.do' );
if( $ret[0] != 200 || $ret[2] != 200 ){
$err = 10;
}
$body = &jcode::euc($ret[1]);
if( $body !‾ m#<title>ConnectONE</title># ){
$err = 11;
}
$title = &jcode::euc('<title>TitleJapanese</title>');
$body = &jcode::euc($ret[3]);
if( $body !‾ m#$title# ){
$err = 12;
}
&MailSend('Exchange-EWS') if( $err > 0);
$err=0;
sub SiteAccess{
my $url1 = shift;
my $url2 = shift;
# $ua,$req,$res;i
my #r;
if($url1 ne ''){
$ua = LWP::UserAgent->new;
$ENV{HTTP_proxy} = "proxy fqdn here";
$ua->env_proxy
$req = HTTP::Request->new(GET => $url1);
$res = $ua->request($req);
$r[0] = $res->code;
$r[1] = $res->content;
}
if($url2 ne ''){
$ua = LWP::UserAgent->new;
$ENV{HTTP_proxy} = "proxy fqdn here";
$ua->env_proxy
$res = $ua->post( $url2,
{
"c" => "don't knwo what that is",
"u" => "users ldap",
"p" => "password"
},
"Content-Type" => "application/x-www-form-urlencoded",
"User-Agent" => "DoCoMo/2.0 N901iS(c100;TB;W24H12;ser123445654654645;icc898114564645667716666f)");
$r[2] = $res->code;
$r[3] = $res->content;
}
return #r;
}
sub MailSend{
my $title = shift;
my $body;
my $from;
my #message;
#the following lines need another file name jcode to display properly. It just means error code or auth error.
#$message[1] = &jcode::jis('[Web]$B%(%i!<%3!<%I(J');
#$message[4] = &jcode::jis('[Web2nd]$B%(%i!<%3!<%I(J');
#$message[7] = &jcode::jis('[POP]$B%(%i!<%3!<%I(J');
$message[10] = &jcode::jis('[EWS]$B%(%i!<%3!<%I(J');
#$message[2] = &jcode::jis('[Web]$B%m%0%$%s2hLL(J');
#$message[5] = &jcode::jis('[Web2nd]$B%m%0%$%s2hLL(J');
#$message[8] = &jcode::jis('[POP]$B%m%0%$%s2hLL(J');
$message[11] = &jcode::jis('[EWS]$B%m%0%$%s2hLL(J');
#$message[3] = &jcode::jis('[Web]auth$B%(%i!<(J');
#$message[6] = &jcode::jis('[Web2nd]auth$B%(%i!<(J');
#$message[9] = &jcode::jis('[POP]auth$B%(%i!<(J');
$message[12] = &jcode::jis('[EWS]auth$B%(%i!<(J');
$from = 'mail#abc.com';
$title = '['.$title.']cnct1 err';
# $title = $title.'['.$MMDD.$HHMM.']';
$body =<<END_OF_BODY;
To: $TO
Subject: $title
From: $from
ConnectOneCheck Error
Date : $MMDD $HHMM
ErrorStatus: $err
ErrorMsg : $message[$err]
END_OF_BODY
open(ML,"| $sendmail") || &error("Can't execute sendmail : $sendmail\n");
print ML $body;
close(ML);
}
OK so I have added a proxy using this function
$ua = LWP::UserAgent->new;
$ENV{HTTP_proxy} = "here is the FQDN of the proxy";
$ua->env_proxy
But it doesn't compile well. It gives me this error:
syntax error at /usr/local/SCRIPTS/www-tools/connectone/ConnectOneCheck.pl line 93, near "$body !"
Unrecognized character \xE2; marked by <-- HERE after f( $body !<-- HERE near column 12 at /usr/local/SCRIPTS/www-tools/connectone/ConnectOneCheck.pl line 93.
Is here someone who can get this script running?
Your script does not compile as it is presented here. In Line 3 where it says
TO='list of
it needs to be changed to
$TO='list of
...and then it compiles for me. Without the error you are getting in line 93.
From my limited viewpoint this means there may actually be some misprint in your code line 93 that did not make it to the code on this side.
If you erase your line 93 in your script and copy the line 93 back into your code, you might be settled.
You have a non-ASCII character OVERLINE (U+203E) (‾) in your source code, and that is the cause of the error you have shown.
The first code point of Unicode characters in the U+2000–206F "General Punctuation" block is \xE2. That was the first clue. The overline is 0xE2 0x80 0xBE in hex.
Perhaps there was some encoding problem that translated the tildes (~) in those few places in your original source into these overlines.
You may also see errors like this when “curly” quotes, en (–) and em (—) dashes, and the like have crept into your source code. Sometimes it's due to well-meaning software such as WordPress or MS Word automatically substituting, for example, straight for curly quotes, which you in turn copy-pasted into your source code.
It's difficult to spot these visually (I didn't notice the overline at first), but this shell one-liner strips characters in the non-ASCII range and then compares side-by-side with the original file on the left:
# assumes Bash shell
sdiff --suppress-common-lines script.pl <(tr -cd '\11\12\15\40-\176' <script.pl)
A similar encoding problem in a Python context, with an error message about \xE2, is described in this SO question. This gave me the idea to look for non-ASCII characters in your source code.
I'm trying to pass parameters in a URL. I don't know what's missing, I tried to see how the URL looks after executing this script.
my $request3 = HTTP::Request->new(GET => $sql_activation);
my $useragent = LWP::UserAgent->new();
$useragent->timeout(10);
my $response2 = $useragent->request($request3);
if ($response2->is_success) {
my $res2 = $response2->content;
if ($res =~ m/[#](.*):(.*)[#]/g) {
my ($key, $username) = ($1, $2);
print "[+] $username:$key \n\n";
}
else {
print "[-] Error \n\n";
}
}
my $link =
"http://localhost/wordpress/wp-login.php?action=rp&key="
. $key
. "&login="
. $username;
sub post_url {
my ($link, $formref) = #_;
my $ua = new LWP::UserAgent(timeout => 300);
$ua->agent('perlproc/1.0');
my $get = $ua->post($link, $formref);
if ($get->is_success) {
print "worked \n";
}
else {
print "Failed \n";
}
}
After executing the script the URL is like this
site/wordpress/wp-login.php?action=rp&key=&login=
Perl has block level scope. You define $key and $username in the block following an if statement. They don't live beyond that.
You need to create them (with my) before that block.
# HERE
my ( $key, $username );
if ( $response2->is_success ) {
my $res2 = $response2->content;
if ( $res =~ m/[#](.*):(.*)[#]/g ) {
# Don't say my again
( $key, $username ) = ( $1, $2 );
}
else { print "[-] Error \n\n"; }
}
I'm trying to save a reference to a string in a class variable.
I wish to access this variable by dereferencing it.
For example in the routine getHeaders instead of using:
my $fileContentsRef = $this->getFileContent;
my $fileContentsRef1 = $$fileContentsRef;
$fileContentsRef1 =~ /Spaltenname.*?Datentyp.*?---\n(.*?)\n\n/gsmi;
I would like to use:
my $fileContentsRef = $this->getFileContent;
$$fileContentsRef =~ /Spaltenname.*?Datentyp.*?---\n(.*?)\n\n/gsmi;
For more details you should see the code at the end.
My problem is, that the program doesn't work when I don't work with the copy( i.e when I don't use $fileContentsRef1). What am I doing / getting wrong? Is it possible to reach the goal in the way I described? Could some give me clues how?
open FILE, "a1.bad";
$file_contents .= do { local $/; <FILE> };
close FILE;
my $log = auswerter->new(\$file_contents);
#-----------------------------------------------------------------
# Subs
#-----------------------------------------------------------------
# CONSTRUCTOR
sub new
{
my $fileRef = $_[1];
my $self = {};
bless $self;
$self->initialize();
if($fileRef) { $self->{fileRef} = $fileRef; }
return $self;
}
sub initialize
{
#-----------------------------------------------------------------
# Configuration
#-----------------------------------------------------------------
my $this = shift;
}
sub setFile {
my $this = shift;
$this->{file} = shift;
}
sub getFileContent
{
my $this = shift;
return $this->{fileRef};
}
sub getHeaders
{
print "HEADERS...\n";
my $this = shift;
my #headers = ();
my $fileContentsRef = $this->getFileContent;
my $fileContentsRef1 = $$fileContentsRef;
$fileContentsRef1 =~ /Spaltenname.*?Datentyp.*?---\n(.*?)\n\n/gsmi;
#headers = split ("\n", $1 );
foreach (#headers)
{
$_ =~ s/^(.*?)\s.*/$1/;
}
return \#headers;
}
sub getErrList
{
print "ERR LIST...\n";
my $this = shift;
my #errors = ();
my $fileContentsRef = $this->getFileContent;
my $fileContentsRef1 = $$fileContentsRef;
$fileContentsRef1 =~ /Spaltenname.*?(Satz.*)ORA.*?^Tabelle/gsmi;
return \#errors if !$1;
#errors = split ("\n\n", $1 );
foreach (#errors)
{
$_ =~ s/.*Spalte (.*?)\..*/$1/msgi;
}
return \#errors;
}
sub getEntries
{
my $this = shift;
my #entries = ();
my $fileContentsRef = $this->getFileContent;
my $fileContentsRef1 = $$fileContentsRef;
$fileContentsRef1 =~ /.*==\n(.*)/gsmi;
#entries = split ("\n", $1 );
return \#entries;
}
sub sqlldrAnalyze
{
my $this = shift;
my $token = shift;
my $errRef =$this->getErrList();
return "" if $#$errRef < 0 ;
my $headersRef = $this->getHeaders();
my $entriesRef = $this->getEntries();
my $i = 0;
my $str = "";
$str = "<html>";
$str .= "<table rules=\"all\">";
$str .= "<tr>";
foreach ( #$headersRef)
{
$str .= "<th>".$_."</th>";
}
$str .= "</tr>";
foreach ( #$entriesRef)
{
my #errOffset = grep { $headersRef->[$_] =~ $errRef->[$i] }0..$#$headersRef ;
my #entries = split($token, $_);
$str .= "<tr>";
foreach (my $j =0; $j <= $#entries;$j++)
{
$str .= "<td nowrap";
$str .= " style=\"background-color: red\"" if $j == $errOffset[0];;
$str .= ">";
$str .= "<b>" if $j == $errOffset[0];
$str .= $entries[$j];
$str .= "</b>" if $j == $errOffset[0];
$str .= "</td>";
}
$str .= "</tr>\n";
$i++;
}
$str .= "</table>";
$str .= "</html>";
return $str;
}
return 1;
When you call your class->new(...) constructor with a filename argument, the new subroutine gets the class name as the first argument, and the filename as the second argument.
In your constructor, you are simply copying the value of $_[1] (the filename) into $self->{FileRef}, but that value is not a reference.
So when you access it, there is no need to use a doubled sigil to dereference the value.
You should run all of your code with the following two lines at the top, which will catch many errors for you (including trying to use strings as references when they are not references):
use strict;
use warnings;
These two lines basically move Perl out of quick one-liner mode, and into a mode more suitable for large development (improved type safety, static variable name checking, and others).
Per the update: If the code you have is working properly when copying the string, but not when dereferencing it directly, it sounds like you may be running into an issue of the string reference preserving the last match position (the g flag).
Try running the following:
my $fileContentsRef = $this->getFileContent;
pos($$fileContentsRef) = 0; # reset the match position
$$fileContentsRef =~ /Spaltenname.*?Datentyp.*?---\n(.*?)\n\n/gsmi;