I have the following perl script.
I need it to invalidate all cookies that are not in the validCookies hash. Note this is only the upper part of my code, the rest deals with printing all the cookies in the #cookieArray() and that works for me.
Since the right cookies are being set that I need to set manually later on in the code. ATM the code is not invalidating the cookies, anyone see why?
use CGI qw(:standard);
use CGI::Cookie;
#cookieArray = ();
#hash of cookie names that should not be set to null
%validCookies = ( cName=> 0, cAddress => 0, cCity => 0, cProvince => 0, cPostalCode => 0, cMail => 0, cDate => 0);
%cook = CGI::Cookie->fetch;
foreach $name ($cook){
if(exists ($validCookies{$name})){
} else {
$temp = CGI::Cookie->new(-name=>$name, -value =>"");
push(#cookieArray, $temp);
}
}
To invalidate a cookie, you must expire it. The following code expires all except the protected cookie names.
It is not necessary to use the CGI::Cookie low-level interface. All the functionality is already exposed through the cookie method.
use strict;
use warnings FATAL => 'all';
use CGI qw();
use Data::Dumper qw(Dumper);
my %protected_names = map { $_ => undef }
qw(cName cAddress cCity cProvince cPostalCode cMail cDate);
my $cgi = CGI->new;
print $cgi->header(
-type => 'text/plain',
-cookie => [
map {
$cgi->cookie(
-name => $_,
-value => (exists($protected_names{$_})
? $cgi->cookie($_)
: q()
),
)
} $cgi->cookie
],
);
print Dumper [$cgi->cookie];
Related
I'm writing my first perl script for the requirement
generate HTTP request against a particular web uri in succession using different URL scheme patterns
use HTTP::Request::Generator 'generate_requests';
use URI;
use HTTP::Request::Common;
use strict; # safety net
use warnings; # safety ne
use Test::LWP::UserAgent 'send_request';
use LWP::UserAgent 'send_request';
use Test::More;
use URI;
use HTTP::Request::Common;
use LWP::UserAgent;
my $g = generate_requests(
method => 'POST',
host => ['example.com','www.example.com'],
pattern => 'https://example.com/{bar,foo,gallery}/[00..99].html',
wrap => sub {
my( $req ) = #_;
# Fix up some values
$req->{headers}->{'Content-Length'} = 666;
},
);
while( my $r = $g->()) {
send_request( $r );
};
I'm using atom editor and activeperl on windows 10, I get following error from running above code.
Undefined subroutine &main::send_request called at C:\Users\ADMINI~1\AppData\Local\Temp\atom_script_tempfiles\0ac821e0-0886-11eb-9588-291dbc37d883 line 57.
I have already installed all necessary modules and lib but i think its unable to refer the method send_request. Pls assist.
NOTE
I have replaced real values in variable for privacy reasons.
UPDATE
I plan to use following module
pattern => 'https://example.{com,org,net}/page_[00..99].html', from
https://metacpan.org/pod/HTTP::Request::Generator.
LWP::UserAgent is an object-oriented module. It doesn't export functions. You want to call send_request like this:
my $ua = 'LWP::UserAgent'->new;
while ( my $r = $g->() ) {
$ua->send_request( $r );
}
That said, send_request is an undocumented internal method. I think it is probably more intended for people who are subclassing LWP::UserAgent. You probably want the request method instead.
my $ua = 'LWP::UserAgent'->new;
while ( my $r = $g->() ) {
my $response = $ua->request( $r );
}
Full code:
use strict;
use warnings;
use HTTP::Request::Generator 'generate_requests';
use LWP::UserAgent;
my $ua = 'LWP::UserAgent'->new;
my $gen = generate_requests(
method => 'POST',
host => [ 'example.com', 'www.example.com' ],
pattern => 'https://example.com/{bar,foo,gallery}/[00..99].html',
wrap => sub {
my ( $req ) = #_;
# Fix up some values
$req->{'headers'}{'Content-Length'} = 666;
},
);
while ( my $req = $gen->() ) {
my $response = $ua->request( $req );
# Do something with $response here?
}
I'm trying to debug a weird warning that is showing up in server logs when a Plack::Request is being parsed. In some cases, a broken UserAgent will send a Content-Length header that looks something like "6375, 6375", which is obviously wrong.
To fix this properly, I need to be able to reproduce the warning. I'd like to include this in a unit test so that I can ensure there are no regressions after the warning is silenced. However, I'm having trouble doing this with Perl. I know this can be done using netcat and socat, but I don't want the unit test to have to rely on other binaries to be installed.
Here is what I've tried:
#!/usr/bin/env perl
use strict;
use warnings;
use JSON::XS qw( encode_json );
use WWW::Mechanize;
my $mech = WWW::Mechanize->new;
$mech->add_handler(
request_prepare => sub {
my ( $req, $ua, $h ) = #_;
$req->headers->header( 'Content-Length' => 9999 );
return;
}
);
my $json = encode_json( { foo => 'bar' } );
$mech->post(
'http://example.com'/url,
'Content-Length' => 999,
Content => $json
);
Output is:
Content-Length header value was wrong, fixed at /opt/perl5.16.3/lib/site_perl/5.16.3/LWP/Protocol/http.pm line 260.
200
That's entirely too helpful for me. :)
If I use HTTP::Request and LWP::UserAgent, it's the same end result.
So, I tried HTTP::Tiny.
#!/usr/bin/env perl
use strict;
use warnings;
use DDP;
use HTTP::Tiny;
use JSON::XS qw( encode_json );
my $http = HTTP::Tiny->new;
my $json = encode_json( { foo => 'bar' } );
my $response = $http->request(
'POST',
'http://example.com'/url',
{ headers => { 'Content-Length' => 999, },
content => $json,
}
);
p $response;
The output is:
{ content => "Content-Length missmatch (got: 13 expected: 999)
",
headers => {
content
-length => 49,
content-type => "text/plain",
},
reason => "Internal Exception",
status => 599,
success => "",
url => "http://example.com'/url",
}
Again, too helpful. At this point, I could use a few suggestions.
Seems like the higher level API's are fixing your error; Here's an example using raw sockets that overcomes this;
#!/usr/bin/env perl
use strict 'vars';
use warnings;
use Socket;
# initialize host and port
my $host = 'www.example.com';
my $port = 80;
# contact the server
open_tcp(F, $host, $port)
or die 'Could not connect to server';
# Send request data
while ( my $request = <DATA> ) {
print F $request;
}
# Get Response
while ( my $response = <F> ) {
print "Response:> $response";
}
close(F);
# TCP Helper
sub open_tcp
{
# get parameters
my ($FS, $dest, $port) = #_;
my $proto = getprotobyname('tcp');
socket($FS, PF_INET, SOCK_STREAM, $proto);
my $sin = sockaddr_in($port,inet_aton($dest));
connect($FS,$sin);
my $old_fh = select($FS);
$| = 1; # don't buffer output
select($old_fh);
}
__DATA__
GET / HTTP/1.1
Host: example.com
Content-Length: 999
-END-
I am trying to customize a script and need to get a POST value from a form using perl.
I have no background of perl but this is a fairly simple thing so I guess it should not be hard.
This is the php version of the code I would like to have in PERL:
<?php
$download = ($_POST['dl']) ? '1' : '0';
?>
I know this may not be at all related to the PERL version but it could help I guess clarifying what exactly I am looking to do.
Well, in that case please have a look at this simple code: This would help you:
#!/usr/bin/perl
use strict;
use warnings;
use CGI;
use CGI::Carp qw(fatalsToBrowser);
sub output_top($);
sub output_end($);
sub display_results($);
sub output_form($);
my $q = new CGI;
print $q->header();
# Output stylesheet, heading etc
output_top($q);
if ($q->param()) {
# Parameters are defined, therefore the form has been submitted
display_results($q);
} else {
# We're here for the first time, display the form
output_form($q);
}
# Output footer and end html
output_end($q);
exit 0;
# Outputs the start html tag, stylesheet and heading
sub output_top($) {
my ($q) = #_;
print $q->start_html(
-title => 'A Questionaire',
-bgcolor => 'white');
}
# Outputs a footer line and end html tags
sub output_end($) {
my ($q) = #_;
print $q->div("My Web Form");
print $q->end_html;
}
# Displays the results of the form
sub display_results($) {
my ($q) = #_;
my $username = $q->param('user_name');
}
# Outputs a web form
sub output_form($) {
my ($q) = #_;
print $q->start_form(
-name => 'main',
-method => 'POST',
);
print $q->start_table;
print $q->Tr(
$q->td('Name:'),
$q->td(
$q->textfield(-name => "user_name", -size => 50)
)
);
print $q->Tr(
$q->td($q->submit(-value => 'Submit')),
$q->td(' ')
);
print $q->end_table;
print $q->end_form;
}
Style advice: you almost never need to assign 0 or 1 to a variable. Simply evaluate the value itself in bool context.
In CGI.pm (CGI), the param method merges POST and GET parameters, so we need to inspect the request method separately:
#!/usr/bin/env perl
use strict;
use warnings FATAL => 'all';
use CGI qw();
my $c = CGI->new;
print $c->header('text/plain');
if ('POST' eq $c->request_method && $c->param('dl')) {
# yes, parameter exists
} else {
# no
}
print 'Do not taunt happy fun CGI.';
With Plack::Request (PSGI), you have different methods for POST (body_parameters) and GET (query_parameters) in addition to the mixed interface (parameters):
#!/usr/bin/env plackup
use strict;
use warnings FATAL => 'all';
use Plack::Request qw();
my $app = sub {
my ($env) = #_;
my $req = Plack::Request->new($env);
if ($req->body_parameters->get_all('dl')) {
# yes
} else {
# no
}
return [200, [Content_Type => 'text/plain'], ['Do not taunt happy fun Plack.']];
};
Here's a good place to start: The Fool's Guide to CGI.pm,
the Perl module for CGI scripting.
This will show you "...how to get the POST value (from a submitted form) and assign it to a variable."
Hope this helps!
The above examples are bit complicated. The below code reads POST values into a variable. You can extract Key Value from that. If its GET then its better to use CGI module.
#!/usr/bin/perl
my $FormData = '';
read(STDIN, $FormData, $ENV{'CONTENT_LENGTH'});
## Variable $FormData holds all POST values passed
use CGI;
my $cgi = new CGI;
print $cgi->header();
print "$FormData";
#use SOAP::Lite ( +trace => all, maptype => {} );
use SOAP::Lite maptype => {};
use LWP::UserAgent;
use HTTP::Request::Common;
#credentials' file
require "c:\\test\\pass.pl";
my $userAgent = LWP::UserAgent->new(keep_alive => 1);
sub SOAP::Transport::HTTP::Client::get_basic_credentials {
return $username => $password;
}
my $soap
= SOAP::Lite
->uri('<mysite>/_vti_bin/lists.asmx')
->on_action(sub {join '/', 'http://schemas.microsoft.com/sharepoint/soap/CopyIntoItemsLocal', $_[1]})
->proxy('<mysite>/_layouts/viewlsts.aspx?BaseType=0', keep_alive => 1);
# my $method = SOAP::Data->name('CopyIntoItemsLocal')
# ->attr({xmlns => 'http://schemas.microsoft.com/sharepoint/soap/'});
# my #params = (SOAP::Data->name(SourceUrl => $source),
# SOAP::Data->name(DestinationUrl => $destination) );
# print $soap->call($method => #params)->result;
my $fileName = 'c:\test\abc.txt';
my $destDir = "<mysite>/Lists/sharepoint1/";
#load and encode Data
my $data;
open(FILE, $fileName) or die "$!";
#read in chunks of 57 bytes to ensure no padding in the middle (Padding means extra space for large files)
while (read(FILE, $buf, 60 * 57)) {
$data .= encode_base64($buf);
}
close(FILE);
#make the call
print "uploading $fileName...";
$lists = $soap->GetList();
my $method = SOAP::Data->name('CopyIntoItemsLocal')->attr({xmlns => 'http://schemas.microsoft.com/sharepoint/soap/'});
my #params = (
SOAP::Data->name('SourceUrl')->value($fileName)->type(''),
SOAP::Data->name('DestinationUrls')->type('')->value(
\SOAP::Data->name('string')->type('')->value($destDir . $fileName)
),
SOAP::Data->name('Fields')->type('')->value(
\SOAP::Data->name('FieldInformation')->type('')->attr({Type => 'File'})->value('')
),
SOAP::Data->name('Stream')->value("$data")->type('')
);
#print Results
print $soap->call($method => #params)->result;
#print $response->headerof('//CopyResult')->attr->{ErrorCode};
#use SOAP::Lite ( +trace => all, maptype => {} );
use SOAP::Lite maptype => {};
use LWP::UserAgent;
use HTTP::Request::Common;
use MIME::Base64 qw(encode_base64);
require "c:\\test\\pass.pl";
my $userAgent = LWP::UserAgent->new(keep_alive=>1);
#setup connection
sub SOAP::Transport::HTTP::Client::get_basic_credentials {
return $username => $password;
}
my $soap = SOAP::Lite
-> uri('http://<mysite>')
-> on_action( sub{ join '/', 'http://schemas.microsoft.com/sharepoint/soap', $_[1] })
-> proxy('http://<mysite>/_vti_bin/lists.asmx',keep_alive => 1);
$lists = $soap->GetListCollection();
quit(1, $lists->faultstring()) if defined $lists->fault();
my #result = $lists->dataof('//GetListCollectionResult/Lists/List');
foreach my $data (#result) {
my $attr = $data->attr;
foreach my $a qw'Title Description DefaultViewUrl Name ID WebId ItemCount' {
printf "%-16s %s\n", $a, $attr->{$a};
}
print "\n";
}
The authentication seems to be working. First I thought that the GetlistCollection Web service is working, as when I made call using that Web service, it returned a page. But I think the call is returning the page I specified in the proxy argument.
I am able to get the collection of list on the particular site on the sharepoint.
I have used GetListCollection. However I did not really understand the code which is printing the list. I just copied it from squish.net. Now I am trying to use the CopyIntoItemsLocal web service.
We have a repository of files on one server (SVN) and I have to write a Perl script which when executed will copy the files and directories from SVN to sharepoint along with the directory structure.
I will appreciate any help or tips. Since it is a big task, I am doing it in modules.
I would start by using soapUI (formerly by eviware, now by smartbear) an open source soapUI testing tool. This will allow you to send soap transactions back and forth without any other user interface. Once you are sure your transactions work and you can parse the data to get what you want, then I would make the move to use Perl to automate those transactions.
This helps you eliminate errors in your requests early on, figure out how to parse responses, and familiarize yourself with the API.
I'm using the AnyEvent::Twitter::Stream module to grab tweets. Ultimately I'm trying to print the tweets to a file but I'm unable (I think) to get the tweet as a JSON object. My code is as follows:
#!/Applications/XAMPP/xamppfiles/bin/perl
use AnyEvent::Twitter::Stream;
my $done = AnyEvent->condvar;
BEGIN {
use Exporter;
our #ISA = qw(Exporter);
our #EXPORT = qw{
&init
};
}
sub print_tweet {
my $tweet = shift;
print $tweet;
}
# receive updates from #following_ids
my $listener = AnyEvent::Twitter::Stream->new(
username => XXXXXX
password => XXXXXX
method => 'sample', # "firehose" for everything, "sample" for sample timeline
decode_json => 1,
on_tweet => sub {
my $tweet = shift;
print_tweet($tweet);
},
on_keepalive => sub {
warn "ping\n";
},
on_delete => sub {
my ($tweet_id, $user_id) = #_; # callback executed when twitter send a delete notification
},
timeout => 45,
);
$done->recv;
Yet when I print out the tweet in the print_tweet subroutine all I get is:
HASH(0x8f0ad0)HASH(0x8f0640)HASH(0x875990)HASH(0x8f0ab0)HASH(0x8e0d80)HASH(0x8f06e0)HASH(0x8f08f0)HASH(0x93ef30)HASH(0x876190)HASH(0x93ee60)HASH(0x8f0610)HASH(0x8f0b00)HASH(0x8e13e0)HASH(0x93ee20)HASH(0x8f0a20)HASH(0x8e1970)HASH(0x8f0900)
I've even tried to print out the tweet assuming it is a hash as follows:
sub print_tweet {
my ($jsonref, $tweet) = #_;
my $tweet = shift;
print %tweet;
}
Yet that produced nothing. It appears that AnyEvent::Twitter::Stream is returning $tweet as an object based on their sample code of:
on_tweet => sub {
my $tweet = shift;
warn "$tweet->{user}{screen_name}: $tweet->{text}\n";
},
And I know I can print out individual objects, but can I get teh raw JSON object? I must be missing something or my 'noob'ness is greater than I thought...
UPDATE
I was able to ALMOST get it by changing print_tweet to the following:
sub print_tweet {
my $tweet = shift;
my $json_output = to_json($tweet);
print $json_output;
}
It prints out MOST of the JSON object but complains about wide characters, which I believe is an issue with the output being utf8 format? I'm unsure how to solve this issue though....
Looks like it's returning a hashref. If you're not sure, you could try doing something like this.
use Data::Dumper;
...
print Dumper $tweet;
That should give you an idea of what's being passed, then you can grab what you want - probably something like this:
print "$tweet->{user}{screen_name}: $tweet->{text}\n";
In print_tweet, you're declaring $tweet twice. First, you assign it the second element of the #_ array, then you redeclare it and assign it the first element of #_, because shift operated on #_ by default.
Of course, if you had use warnings turned on, you would have seen
"my" variable $tweet masks earlier declaration in same scope
That's why you should always use strict; use warnings; at the top of your code.
The strings of output that you're seeing are hash references, the result of printing what's in the first argument to print_tweet (what you initially assign to $json_ref). If you want to print out the value of $tweet, get rid of the line where you clobber it with shift.
Figured it out. Need to use the JSON module and encode. When encoding you MUST use the {utf8 => 1} option to account for the utf8 characters you get form Twitter. Final code is here:
#!/Applications/XAMPP/xamppfiles/bin/perl
use JSON;
use utf8;
use AnyEvent::Twitter::Stream;
my $done = AnyEvent->condvar;
BEGIN {
use Exporter;
our #ISA = qw(Exporter);
our #EXPORT = qw{
&init
};
}
sub print_tweet {
my $tweet = shift;
my $json_output = to_json($tweet, {utf8 => 1});
print $json_output;
print "\n";
}
# receive updates from #following_ids
my $listener = AnyEvent::Twitter::Stream->new(
username => XXXXXXXX
password => XXXXXXXX
method => 'sample', # "firehose" for everything, "sample" for sample timeline
on_tweet => sub {
my $tweet = shift;
print_tweet($tweet);
},
on_keepalive => sub {
warn "ping\n";
},
on_delete => sub {
my ($tweet_id, $user_id) = #_; # callback executed when twitter send a delete notification
},
timeout => 45,
);
$done->recv;
Thanks to the help you guys gave, the DataDumper at least let me verify the format, it just didn't produce the final result.