I've written a short Perl script that lists the current cookies for the website, but somehow it reports the cookie's domain and expires empty. What am I doing wrong or am I misunderstanding the mechanics behind cookies?
My ultimate goal is to be able to delete exsisting cookies with a button.
The script is live here, but it may help if you visit my blog first so there are actually some cookies set. Here is my source code:
use warnings;
use strict;
use CGI::Cookie;
my $table;
my %cookies = CGI::Cookie->fetch;
if ( keys %cookies ) {
$table .= "<table border=\"3\" cellpadding=\"5\">";
$table .= "<caption>COOKIES</caption>";
$table .= "<tr><th>Name</th><th>Domain</th><th>Path</th><th>Expires</th>
<th align=\"left\">Value</th></tr>";
foreach my $cookie ( keys %cookies ) {
$table .= "<tr>";
$table .= "<td>$cookie</td>";
$table .= "<td>" . $cookies{ $cookie }->domain() . "</td>";
$table .= "<td>" . $cookies{ $cookie }->path . "</td>";
$table .= "<td>" . $cookies{ $cookie }->expires . "</td>";
$table .= "<td>" . $cookies{ $cookie }->value . "</td>";
$table .= "</tr>";
}
$table .= "</table>";
}
print "Content-Type: text/html\n\n";
print "<html>\n";
print "<head></head>\n";
print "<body>\n";
print "$table";
print "</body>\n";
print "</html>\n";
Regardless the various cookies on various websites where I install the script, the output looks like this and Domain and Expires is always empty:
+-----------------------------------------------------------------------------------------+
| Name | Domain | Path | Expires | Value |
|---------------+--------+------+---------+-----------------------------------------------|
| bb2_screener_ | | / | | 1379007156 2001:980:1b7f:1:a00:27ff:fea6:a2e7 |
+-----------------------------------------------------------------------------------------+
Browsers does not provide any meta information to the server about the cookies they send. There isn't even a way for them to send it. What the browser sends looks like the following:
Cookie: a=b; c=d; e=f
Related
my $url = "https://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=pubmed&term=journal+of+medical+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]&usehistory=y";
print "\n before url \n";
print $url;
#post the esearch URL
my $output = get($url);
print $output;
I have not used perl ever before.
If I hit this URL in browser, I do get the XML.
However, From what I see in output from script, $output is empty and
print $output;
returns
Use of uninitialized value in print at ./extractEmails.pl line 48.
Please suggest what's wrong and how to fix it
Edit:
As suggested, complete code:
#!/usr/bin/perl -w
# A perlscript written by Joseph Hughes, University of Glasgow
# use this perl script to parse the email addressed from the affiliations in PubMed
use strict;
use LWP::Simple;
my ($query,#queries);
#Query the Journal of Virology from 2014 until the present (use 3000)
$query = 'journal+of+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Journal of General Virology
$query = 'journal+of+general+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Virology
$query = 'virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Archives of Virology
$query = 'archives+of+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Virus Research
$query = 'virus+research[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Antiviral Research
$query = 'antiviral+research[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Viruses
$query = 'viruses[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
push(#queries,$query);
#Journal of Medical Virology
$query = 'journal+of+medical+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]';
# global variables
push(#queries,$query);
my %emails;
my $emailcnt=0;
my $count=1;
#assemble the esearch URL
foreach my $query (#queries){
my $base = 'https://eutils.ncbi.nlm.nih.gov/entrez/eutils/';
#my $url = $base . "esearch.fcgi?db=pubmed&term=$query&usehistory=y";
my $url = "https://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=pubmed&term=journal+of+medical+virology[journal]+AND+2014[Date+-+Publication]:3000[Date+-+Publication]&usehistory=y";
print "\n before url \n";
print $url;
#post the esearch URL
my $output = get($url);
print "\n before output \n";
print get($url);
print $output;
#parse WebEnv, QueryKey and Count (# records retrieved)
my $web = $1 if ($output =~ /<WebEnv>(\S+)<\/WebEnv>/);
my $key = $1 if ($output =~ /<QueryKey>(\d+)<\/QueryKey>/);
my $count = $1 if ($output =~ /<Count>(\d+)<\/Count>/);
#retrieve data in batches of 500
my $retmax = 500;
for (my $retstart = 0; $retstart < $count; $retstart += $retmax) {
my $efetch_url = $base ."efetch.fcgi?db=pubmed&WebEnv=$web";
$efetch_url .= "&query_key=$key&retmode=xml";
my $efetch_out = get($efetch_url);
my #matches = $efetch_out =~ m(<Affiliation>(.*)</Affiliation>)g;
#print "$_\n" for #matches;
for my $match (#matches){
if ($match=~/\s([a-zA-Z0-9\.\_\-]+\#[a-zA-Z0-9\.\_\-]+)$/){
my $email=$1;
$email=~s/\.$//;
$emails{$email}++;
}
}
}
my $cnt= keys %emails;
print "$query\n$cnt\n";
}
print "Total number of emails: ";
my $cnt= keys %emails;
print "$cnt\n";
my #email = keys %emails;
my #VAR;
push #VAR, [ splice #email, 0, 100 ] while #email;
my $batch=100;
foreach my $VAR (#VAR){
open(OUT, ">Set_$batch\.txt") || die "Can't open file!\n";
print OUT join(",",#$VAR);
close OUT;
$batch=$batch+100;
}
I recommend against using LWP::Simple for any reason because it is impossible to configure it or handle errors usefully. Using LWP::UserAgent which it wraps is nearly as simple anyway (though the error handling is a bit complicated). The below examples would replace the use LWP::Simple; and my $output = get($url); lines.
use strict;
use warnings;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new(timeout => 30);
my $response = $ua->get($url);
unless ($response->is_success) {
# the Client-Warning, Client-Aborted, and X-Died headers each may be set on client/transport errors
die $response->status_line;
}
my $output = $response->decoded_content;
The core HTTP::Tiny is also simple.
use strict;
use warnings;
use HTTP::Tiny;
my $ua = HTTP::Tiny->new;
my $response = $ua->get($url);
unless ($response->{success}) {
die $response->{status} == 599 ? $response->{content} : "$response->{status} $response->{reason}";
}
my $output = $response->{content};
If you really want an LWP::Simple approach that will at least report transport errors, try ojo from Mojolicious:
perl -Mojo -E'say g(shift)->text' http://example.com
In a script rather than a oneliner, you can use Mojo::UserAgent directly, and also handle HTTP errors like above:
use strict;
use warnings;
use Mojo::UserAgent;
my $ua = Mojo::UserAgent->new;
my $response = $ua->get($url)->result;
unless ($response->is_success) {
die $response->code . ' ' . $response->message;
}
my $output = $response->text;
I'm trying to make an HTTP GET request with Cisco Prime:
#!/opt/local/bin/perl -w
use strict;
use JSON-support_by_pp;
use LWP 5.64;
use LWP::UserAgent;
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
my $ua = LWP::UserAgent->new;
my $BASE_URL = 'https://Host_name/webacs/api/v1/';
my $UN = "Username";
my $PW = "Password";
sub fetch ($) {
my ( $url ) = #_;
my $req = HTTP::Request->new( GET => $BASE_URL . $url );
$req->authorization_basic( $UN, $PW );
return $ua->request( $req )->content or die( "Cannot read from " . $BASE_URL . $url );
}
my $content = fetch( 'data/AccessPoints.json?.full=true' );
my $json = new JSON;
# these are some nice json options to relax restrictions a bit:
my $json_text =
$json->allow_nonref->utf8->relaxed->escape_slash->loose->allow_singlequote->allow_barekey->decode( $content );
foreach my $ap ( #{ $json_text->{queryResponse}->{'entity'} } ) {
print "------------------------\nAccess Point " . $ap->{'accessPointsDTO'}->{'#id'} . "\n";
print "Model:" . $ap->{'accessPointsDTO'}->{'model'} . "\n";
print "MAC Address:" . $ap->{'accessPointsDTO'}->{'macAddress'} . "\n";
print "Serial Number:" . $ap->{'accessPointsDTO'}->{'serialNumber'} . "\n";
print "Software Version:" . $ap->{'accessPointsDTO'}->{'softwareVersion'} . "\n";
print "Status:" . $ap->{'accessPointsDTO'}->{'status'} . "\n";
print "Location:" . $ap->{'accessPointsDTO'}->{'location'} . "\n";
What do I do wrong? I have already tried with curl in shell and it works:
curl --tlsv1 --user USER:PASSWORD--insecure https://Host_name/webacs/api/v1/data/AccessPoints.json?.full=true
but my Perl script doesn't work.
I have this error:
malformed JSON string, neither array, object, number, string or atom, at character offset 0 (before "Can't connect to 10....") at ersteProbe.pl line 28.
Fix already. Thank you Borodin :)
New question:
I need authentication for Cisco Prime.
Code works already, but authentication doesn't work.
I have with error
500 Can't connect to 10.10.10.10:443 (certificate verify failed) at ersteProbeAuth.pl line 27.
Line 27:
die $res->status_line unless $res->is_success;
I'm rather new in Perl und cann't fix this myself. If you have Idee, I'll be happy :)
#!/opt/local/bin/perl -w
use strict;
use warnings;
use JSON -support_by_pp;
use LWP 5.64;
use LWP::UserAgent;
use MIME::Base64;
use REST::Client;
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
my $ua = LWP::UserAgent->new;
my $BASE_URL = 'https://10.10.10.10/webacs/api/v1/';
my $UN='admin';
my $PW='admin';
# coding with Base 64
my $sys_id='Balalalalalal';
my $encoded_auth = encode_base64("$UN:$PW", '');
sub fetch {
my ($url) = #_;
my $res = $ua->get($BASE_URL . $url,
{'Authorization' => "Basic $encoded_auth",
'Accept' => 'application/json'});
die $res->status_line unless $res->is_success;
my $json = $res->decoded_content;
return $json
}
my $content = fetch('data/AccessPoints.json?.full=true/$sys_id');
my $json = new JSON;
# these are some nice json options to relax restrictions a bit: my$json_text=$json->allow_nonref->utf8->relaxed->escape_slash->loose->allow_singlequote->allow_barekey->decode($content);
foreach my $ap (#{$json_text->{queryResponse}->{'entity'}}){
print "------------------------\nAccess Point ".$ap->{'accessPointsDTO'}->{'#id'}."\n";
print "Model:".$ap->{'accessPointsDTO'}->{'model'}."\n";
print "MAC Address:".$ap->{'accessPointsDTO'}->{'macAddress'}."\n";
print "Serial Number:".$ap->{'accessPointsDTO'}->{'serialNumber'}."\n";
print "Software Version:".$ap->{'accessPointsDTO'}->{'softwareVersion'}."\n";
print "Status:".$ap->{'accessPointsDTO'}->{'status'}."\n";
print "Location:".$ap->{'accessPointsDTO'}->{'location'}."\n";
}
It's hard to tell what's wrong without access to the web page, but almost certainly your request has failed
I suggest you replace your fetch subroutine with this
sub fetch {
my ( $url ) = #_;
my $res = $ua->get( $BASE_URL . $url );
die $res->status_line unless $res->is_success;
my $json = $res->decoded_content;
return $json;
}
Print your raw answer from server in console.
malformed JSON string, neither array, object, number, string or atom, at character offset 0 (before "Can't connect to 10....")
"Can't connect to 10...."
Maybe, your code is not have connect
I am going through the basic example for CGI::Application but when I try to add a 3rd mode, it seems the query object is refusing to use my supplied value.
webapp.cgi:
#!/usr/bin/perl
use webapp;
my $webapp = WebApp->new();
$webapp->run();
webapp.pm:
package WebApp;
use base 'CGI::Application';
sub setup {
my $self = shift;
$self->start_mode('mode1');
$self->mode_param('rm');
$self->run_modes(
'mode1' => 'do_stuff',
'mode2' => 'do_more_stuff',
'mode3' => 'do_something_else'
);
}
sub do_stuff {
my $self = shift;
my $q = $self->query();
my $output = '';
$output .= $q->start_html(-title => 'Widget Search Form');
$output .= $q->start_form();
$output .= $q->textfield(-name => 'widgetcode');
$output .= $q->hidden(-name => 'rm', -value => 'mode2');
$output .= $q->submit();
$output .= $q->end_form();
$output .= $q->end_html();
return $output;
}
sub do_more_stuff {
my $self = shift;
my $q = $self->query();
my $widgetcode = $q->param("widgetcode");
my $output = '';
$output .= $q->start_html(-title => 'List of Matching Widgets');
$output .= $q->start_form();
$output .= $q->textfield(-name => 'widgetcode');
$output .= $q->hidden(-name => 'rm', -value => 'mode3');
# ^^^^^^
# this value is being ignored
$output .= $q->submit();
$output .= $q->end_form();
$output .= $q->end_html();
return $output;
}
sub do_something_else {
my $self = shift;
my $q = $self->query();
my $widgetcode = $q->param("widgetcode");
my $output = '';
$output .= $q->start_html(-title => 'Widgets details');
$output .= $q->start_form();
$output .= $q->textfield(-name => 'widgetcode');
$output .= $q->hidden(-name => 'rm', -value => 'mode4');
$output .= $q->submit();
$output .= $q->end_form();
$output .= $q->end_html();
return $output;
}
1;
So it works fine to load the first page (mode1), it gives me the form, and I can submit it and reach the second page (mode2), but I cannot reach mode3, because the rm param is being set to "mode2", despite the fact that, as you can read above, I am setting it to "mode3". That means I am sent back to mode2 again. I can change the rm to be rm2 or something else and then the right value gets picked up, but obviously that's not helpful, since the rm variable is what is used to set the mode.
I don't have experience with CGI.pm (which supplies the query object) and as you can tell, I am only just starting to learn CGI::Application, so I don't know what is going on or how to solve this.
It seems the perlmonks had the wisdom: Hidden fields using CGI
You can use the -override parameter to force it to use the default value.
Which in my case would be used as follows:
$output .= $q->hidden(-name => 'rm', -value => 'mode3' , -override => 1);
Hope that helps whoever finds this question through a search, since this isn't obvious at all.
Yes, it appears that the hidden method will use the current form value if one exists instead of what you specify as the default. This could be observed with the following code when accessing a view with ?rm=mode2:
$output .= $q->hidden(-name => 'rm', -value => 'mode3'); # Prints mode2
$q->param('rm' => 'mode3');
$output .= $q->hidden(-name => 'rm'); # Print mode3
As you found, the best solution is to use the override flag as documented in CGI #Form Elements
$output .= $q->hidden(-name => 'rm', -value => 'mode3', -override => 1); # Print mode3
Within my php framework (CakePHP), is a i18n tool for generating POT files. The header of the file is generated like so:
protected function _writeHeader() {
$output = "# LANGUAGE translation of CakePHP Application\n";
$output .= "# Copyright YEAR NAME <EMAIL#ADDRESS>\n";
$output .= "#\n";
$output .= "#, fuzzy\n";
$output .= "msgid \"\"\n";
$output .= "msgstr \"\"\n";
$output .= "\"Project-Id-Version: PROJECT VERSION\\n\"\n";
$output .= "\"POT-Creation-Date: " . date("Y-m-d H:iO") . "\\n\"\n";
$output .= "\"PO-Revision-Date: YYYY-mm-DD HH:MM+ZZZZ\\n\"\n";
$output .= "\"Last-Translator: NAME <EMAIL#ADDRESS>\\n\"\n";
$output .= "\"Language-Team: LANGUAGE <EMAIL#ADDRESS>\\n\"\n";
$output .= "\"MIME-Version: 1.0\\n\"\n";
$output .= "\"Content-Type: text/plain; charset=utf-8\\n\"\n";
$output .= "\"Content-Transfer-Encoding: 8bit\\n\"\n";
$output .= "\"Plural-Forms: nplurals=INTEGER; plural=EXPRESSION;\\n\"\n\n";
return $output;
}
I am curious to know if the following:
$output .= "#, fuzzy\n";
$output .= "msgid \"\"\n";
$output .= "msgstr \"\"\n";
breaks some sort of standards of gettext. If it does not, I would love an explanation as to why one would put that in the header of the file.
I suppose it's 'fuzzy' because the headers are not complete. i.e. the template entries will be filled in when the PO files are generated from the POT.
The official Gettext xgettext tool that generates POT files from source code also adds the fuzzy flag to the header. By that token it is certainly not against the standard.
I am attempting to display some info from an infoblox device. When I run this code in a browser using an html post, the table that displays MAC address entries does not display the values from the api. When I run this code in the unix command-line, the variables show up appropriately. Any Advice?
#!/usr/bin/perl
use strict;
use Infoblox;
use CGI;
my $cgi = new CGI;
print
$cgi->header() .
$cgi->start_html( -title => 'Form Results') .
$cgi->h1('Form Results') . "\n";
my #params = $cgi->param();
my $username = $cgi->param('username');
print '<table border="1" cellspacing="0" cellpadding="0">' . "\n";
foreach my $parameter (sort #params) {
print "<tr><th>$parameter</th><td>" . $cgi->param($parameter) . "</td></tr>\n";
}
print "</table>\n";
print "<p>$username</p>";
print $cgi->end_html . "\n";
#Create a session to the Infoblox appliance
my $session = Infoblox::Session->new(
master => "server", #appliance host ip
username => "username", #appliance user login
password => "password" #appliance password
);
unless ($session) {
die("Construct session failed: ",
Infoblox::status_code() . ":" . Infoblox::status_detail());
}
print "Session created successfully\n<br>";
my #list = $session->get(
object => "Infoblox::DHCP::MAC",
filter => "macfilter",
);
my $nextobject = $list[0];
print <<EOF;
<br>
<table>
<tr>
<th>MAC</th>
<th>Description</th>
<th>UserID</th>
<th>Expiration</th>
</tr>
EOF
foreach my $test ( #list ) {
print "<tr>";
print "<td> $test->mac()</td>";
print "<td>" . scalar($test->comment()) . "</td>\n";
print "<td>" . scalar($test->username()) . "</td>\n";
print "<td>" . scalar(localtime(scalar($test->expiration_time()))) . "</td>\n";
print "</tr>";
}
exit (0);
I had incorrect permissions. The script was running as user nobody and would not display the items correctly on the web page.