I'm having problems with the BUILD method, I want to connect to an HTML-based chat. I wish this class would keep me logged in order to execute the action of sending and receiving messages.
I tried the way down, but it seems that causes a stress on the server while running.
package Shoutbox;
use common::sense;
use WWW::Mechanize;
use WWW::Mechanize::DecodedContent;
use JSON -support_by_pp;
use URI::Escape;
use Moose;
our $url = WWW::Mechanize->new();
$url->get("http://www.forum-invaders.com.br/vb/login.php");
$url->submit_form(
fields => {
vb_login_username => 'login',
vb_login_password => 'senha',
});
has 'msg' => (is => 'rw', isa => 'Str');
sub send_msg {
my $self = shift;
my $message = $self->msg;
my $content = $url->decoded_content;
$content =~ /SECURITYTOKEN = "(.*?)"/g ;
my $token = $1;
if($content =~ /Bem-vindo/gi) {
my $msg = uri_escape($message);
$url->post("http://www.forum-invaders.com.br/vb/vbshout.php",{
message => $msg, securitytoken => $token,
do => "ajax", action => "save", instanceid => "2"});
}
}
sub get_msg{
my $r = $url->get("http://www.forum-invaders.com.br/vb/vbshout.php?type=activeusers&do=ajax&action=fetch&instanceid=2");
my $json = JSON->new->relaxed;
my $s = $json->decode($r->decoded_content);
my $msg = $s->{"shouts"}->{0}->{"message_raw"};
my $user = $s->{"shouts"}->{0}->{"musername"};
my $name;
if ($user =~ />(.+)<\/span/gi) {$name = $1;}
else {$name = $user}
my $now = join(" => ", $name, $msg) . "\n";
return $now;
}
no Moose;
1;
Soon I received an advice to use the BUILD method, so I did so but did not work.
package Shoutbox;
use common::sense;
use WWW::Mechanize;
use WWW::Mechanize::DecodedContent;
use JSON -support_by_pp;
use URI::Escape;
use Moose;
has 'login' => (is => 'rw', isa => 'Str');
has 'password' => (is => 'rw', isa => 'Str');
our $url;
our $token;
sub BUILD{
my $self = shift;
$url = WWW::Mechanize->new();
$url->get("http://www.forum-invaders.com.br/vb/login.php");
$url->submit_form(
fields => {
vb_login_username => $self->login,
vb_login_password => $self->password,
});
my $content = $url->decoded_content;
$content =~ /SECURITYTOKEN = "(.*)"/g;
if ($1 eq "guest"){
print "Login Error\n";
exit;
}
else (print "Login OK!\n";}
$token = $1;
print $token . "\n";
}
has 'msg' => (is => 'rw', isa => 'Str');
sub send_msg {
BUILD;
my $self = shift;
my $message = $self->msg;
my $msg = uri_escape($message);
$url->post("http://www.forum-invaders.com.br/vb/vbshout.php",{
message => $msg, securitytoken => $token,
do => "ajax", action => "save", instanceid => "2"});
}
sub get_msg{
BUILD;
my $r = $url->get("http://www.forum-invaders.com.br/vb/vbshout.php?type=activeusers&do=ajax&action=fetch&instanceid=2");
my $json = JSON->new->relaxed;
my $s = $json->decode($r->decoded_content);
my $msg = $s->{"shouts"}->{0}->{"message_raw"};
my $user = $s->{"shouts"}->{0}->{"musername"};
my $name;
if ($user =~ />(.+)<\/span/gi) {$name = $1;}
else {$name = $user}
my $now = join(" => ", $name, $msg) . "\n";
return $now;
exit;
}
no Moose;
1;
Related
I am extending CGI and trying to add a simple router to it, just for fun.
Here are my Test::More tests
use strict;
use warnings;
use Data::Dumper;
use Test::More tests => 4;
use CGI::Router;
my $router = CGI::Router->new;
my $resp;
## 1. test ##
$ENV{'REQUEST_URI'} = '/';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /', sub {
# print Dumper #_;
return 'Hello 1';
});
# print Dumper $resp;
ok( $resp eq 'Hello 1' );
## 2. test ##
$ENV{'REQUEST_URI'} = '/hello';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello', sub {
# print Dumper #_;
return 'Hello 2';
});
# print Dumper $resp;
ok( $resp eq 'Hello 2' );
## 3. test ##
$ENV{'REQUEST_URI'} = '/hello/kitty';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello/:who', sub {
# print Dumper #_;
return 'Hello 3';
});
# print Dumper $resp;
ok( $resp eq 'Hello 3' );
## 4. test ##
$ENV{'REQUEST_URI'} = '/hello/kitty/kat';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello/:who/:what', sub {
# print Dumper #_;
return 'Hello kitty kat';
});
# print Dumper $resp;
ok( $resp eq 'Hello kitty kat' );
$router->run;
Here is my module
package CGI::Router;
use strict;
use warnings;
use parent 'CGI';
use Carp;
use Data::Dumper;
sub connect {
my ( $self, $req, $subr ) = #_;
$self->{routes} //= {};
$self->{env} //= \%ENV;
if ( ! exists $self->{routes}->{$req} ) {
$self->{routes}->{$req} = {
handler => $subr,
pattern => $self->build_pattern( $req ),
method => $req =~ /^(GET|PUT|POST|DELETE)/
};
} else {
Carp::croak( "Similar request already exists $req!" );
}
# Get current request destination
# TODO: Add that stupid IIS HTTP header
$self->{destination} = $self->{env}->{REQUEST_URI};
$self->{method} = $self->{env}->{REQUEST_METHOD};
return $self->mapper();
}
sub mapper {
my $self = shift;
my $router;
my #params;
foreach my $key ( keys %{ $self->{routes} } ) {
my $route = $self->{routes}->{$key};
if ( $self->{method} eq $route->{method} &&
$self->{destination} =~ $route->{pattern} ) {
#params = $self->{destination} =~ $route->{pattern};
$router = $route;
}
}
return $router->{handler}->( #params );
}
sub build_pattern {
my ( $self, $pattern ) = #_;
$pattern =~ s/(GET|POST|PUT|DELETE)\s?//i;
$pattern = do {
# Replace something like /word/:token with /word/(^:([a-z]+))
$pattern =~ s!
(\:([a-z]+))
!
if ( $2 ) {
"([^/]+)"
}
!gex;
"^$pattern\$";
};
return $pattern;
}
sub run {
}
1;
When the test cases run and I Dump e.g $resp in ## 4. test ## the returned value is not some version of "Hello kitty" but 'GET'.
Here is the output of the test
1..4
ok 1
ok 2
ok 3
ok 4
Why do all the subroutines return 'GET', I don't see where I generate this output.
I know a ton of similar frameworks exists, I am just doing this for fun :)
I modified your code to work/not error. Take it or leave it ;)
CGI/Router.pm:
Things changed:
build_pattern returns a compiled regex via qr/$pattern/
connect param handling is less confusing. You were taking $self, #args off #_, but then taking $req, $subr from #args and doing nothing else with it. So I moved them up
connect returns the value of run
$foo = $bar if !defined $foo; is better written as $foo //= $bar;. Similar to $foo ||= $bar but checks for definedness rather than truth.
Code:
package CGI::Router;
use strict;
use warnings;
use parent 'CGI';
use Carp;
use Data::Dumper;
sub connect {
my ( $self, $req, $subr ) = #_;
$self->{routes} //= {};
$self->{env} //= \%ENV;
if ( !exists $self->{routes}->{$req} ) {
$self->{routes}->{$req} = {
handler => $subr,
pattern => $self->build_pattern($req),
method => $req =~ /^(GET|PUT|POST|DELETE)/
};
}
else {
Carp::croak("Similar request already exists $req!");
}
# Get current request destination
# TODO: Add that stupid IIS HTTP header
$self->{destination} = $self->{env}->{REQUEST_URI};
$self->{method} = $self->{env}->{REQUEST_METHOD};
return $self->run();
}
sub build_pattern {
my ( $self, $pattern ) = #_;
$pattern =~ s/(GET|POST|PUT|DELETE)\s?//i;
$pattern = do {
# Replace something like /word/:token with /word/(^:([a-z]+))
$pattern =~ s!
(\:([a-z]+))
!
if ( $2 ) {
"([^/]+)"
}
!gex;
"^$pattern\$";
};
return qr/$pattern/;
}
sub run {
my $self = shift;
my $router;
my #params;
foreach my $key ( keys %{ $self->{routes} } ) {
my $route = $self->{routes}->{$key};
if ( $self->{method} eq $route->{method}
&& $self->{destination} =~ $route->{pattern} )
{
#params =
$self->{destination} =~ $route->{pattern}; # Not fully working yet
$router = $route;
}
}
return $router->{handler}->(#params);
}
1;
test-router.pl:
Things changed:
The BEGIN block was doing setup that you ought not do for a test script. I.e. randomising the flow.. so I ditched that off
Added the environment variables for each test case
Code:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Test::More tests => 4;
use CGI::Router;
my $router = CGI::Router->new;
my $resp;
## 1. test ##
$ENV{'REQUEST_URI'} = '/';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /', sub {
# print Dumper #_;
return 'Hello 1';
});
print Dumper $resp;
ok( $resp eq 'Hello 1' );
## 2. test ##
$ENV{'REQUEST_URI'} = '/hello';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello', sub {
# print Dumper #_;
return 'Hello 2';
});
print Dumper $resp;
ok( $resp eq 'Hello 2' );
## 3. test ##
$ENV{'REQUEST_URI'} = '/hello/kitty';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello/:who', sub {
# print Dumper #_;
return 'Hello 3';
});
print Dumper $resp;
ok( $resp eq 'Hello 3' );
## 4. test ##
$ENV{'REQUEST_URI'} = '/hello/kitty/kat';
$ENV{'REQUEST_METHOD'} = 'GET';
$resp = $router->connect('GET /hello/:who/:what', sub {
# print Dumper #_;
return 'Hello kitty kat';
});
print Dumper $resp;
ok( $resp eq 'Hello kitty kat' );
I've written a cgi script and it does the following:
#!/usr/bin/perl
use strict;
use warnings;
use CGI qw(:cgi-lib :standard);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
my $q = new CGI;
print $q->header;
print "<center>";
print $q->h1('Let\'s do something!');
print "</center>";
print $q->start_html(-title => 'Do something');
print $q->end_form;
our %in;
&ReadParse(%in);
my #keys = keys %in;
my #values = values %in;
main();
sub main{
print "<center>";
my $q0 = new CGI;
print $q0->start_form(
-name => 'sniff_button',
-method => 'POST',
-enctype => &CGI::URL_ENCODED,
);
print $q0->submit(
-name => 'button',
-value => 'Do something',
);
print $q0->end_form;
print "</center>";
}
What I want to do is add some parameters manually, because the next that depends on the previous state and not only on the current state (So I have to pass a parameter twice.).
I've done stuff with param() and URI, but none of them work. Any advice?
A hidden field is the answer:
sub main{
print "<center>";
my $q0 = new CGI;
print $q0->start_form(
-name => 'sniff_button',
-method => 'POST',
-enctype => &CGI::URL_ENCODED,
);
print $q0->hidden(
-name => 'machine_state',
-default => 'some_previous_value');
print $q0->submit(
-name => 'button',
-value => 'Do something',
);
print $q0->end_form;
print "</center>";
}
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
I have an issue communicating with a external system via IO::Socket::Inet.
I try to login and send multiple commands to the system but unfortunately this does'n work if the command print in line 58 is under conditional statement.
The conditional statements in this case is required to handle response data.
package Net::Cli::Cisco;
use 5.006;
use strict;
use warnings FATAL => qw(all);
use IO::Socket::INET;
use Carp;
use Data::Dumper;
$| = 1;
sub new {
my $class = shift;
my %args = #_;
my $self = bless {
_host => $args{host} || carp('No hostname defined'),
_username => $args{username} || carp('No username defined'),
_password => $args{password} || carp('No password defined'),
_logged_in => 0,
}, $class;
return $self;
}
sub connect {
my $self = shift;
my $host = $self->{_host};
my $port = 23;
my $handle = IO::Socket::INET->new(
Proto => "tcp",
PeerAddr => $host,
PeerPort => $port,
Type => SOCK_STREAM,
Timeout => 3
) or die "can't connect to port $port on $host: $!";
my $shc = "\r\n";
$self->{shc} = $shc;
$self->{handle} = $handle;
}
sub getInterface {
my ($self) = #_;
$self->connect;
my #cmd_list = ( "sh clock", "sh ip int brief" );
$self->send_cmd(#cmd_list);
}
sub send_cmd {
my ( $self, #cmd_list ) = #_;
my $handle = $self->{handle};
my $response;
while ( $response = <$handle> ) {
if ( $response =~ m/^Username:/ ) {
print "Conditional statements exec done!\n";
print $handle $self->{_username} . $self->{shc};
}
#print $handle $self->{_username} . $self->{shc};
print $response;
print $handle $self->{_password} . $self->{shc};
print $handle "enable" . $self->{shc};
print $handle $self->{_password} . $self->{shc};
print $handle "term leng 0" . $self->{shc};
foreach my $cmd (#cmd_list) {
print $handle "$cmd" . $self->{shc};
}
print $handle "exit" . $self->{shc};
}
close($handle);
}
1;
my $x = __PACKAGE__->new(
"host" => "1.1.1.1",
"username" => "user",
"password" => "pw"
);
$x->getInterface;
Well, I can't see why my code is wrong.
Note: If I recommend line 61 everything working fine.
Any ideas?
After comment from ikegami please find working subroutine below:
sub send_cmd {
my ( $self, #cmd_list ) = #_;
my $handle = $self->{handle};
my $response;
START: while ( $response = <$handle> ) {
print $response;
if ( $response =~ m/[^Username:|^Password:|\$%#:>]/ ) {
print $handle $self->{_username} . $self->{shc};
print $handle $self->{_password} . $self->{shc};
print $handle "enable" . $self->{shc};
print $handle $self->{_password} . $self->{shc};
print $handle "term leng 0" . $self->{shc};
foreach my $cmd (#cmd_list) {
print $handle "$cmd" . $self->{shc};
}
print $handle "exit" . $self->{shc};
} else {
goto START;
}
}
close($handle);
I am having a problem getting/staying logged in with perl mechanize to a website
Looking at the headers, it appears that the JSESSIONID keeps changing. I am using a cookie jar, but I think it's getting overwritten somehow.
#!/usr/bin/perl
use strict;
use warnings;
use WWW::Mechanize;
use HTTP::Cookies;
use Crypt::SSLeay;
use LWP::UserAgent;
use Crypt::SSLeay::CTX;
use Crypt::SSLeay::Conn;
use Crypt::SSLeay::X509;
use LWP::Simple qw(get);
use LWP::Debug;
my $cookie_jar = HTTP::Cookies->new(ignore_discard => 1);
my $agent = WWW::Mechanize->new(cookie_jar => $cookie_jar, noproxy=>0);
$agent->agent_alias('Linux Mozilla');
$ENV{HTTPS_CA_DIR} = 'cert/';
my $user = 'xxxx';
my $pass = 'xxxx';
my $url = '';
print "\n\n=========================================================\nGOING TO LOGIN PAGE:\n";
my $res = $agent->get($url);
for my $key ( $res->header_field_names() ) {
print $key, " : ", $res->header( $key ), "\n";
}
print "cookie: ".$agent->cookie_jar->as_string();
$agent->form_name('loginForm');
$agent->set_fields(
userId => $user,
password => $pass
);
$agent->submit();
print "\n\n=========================================================\nREDIRECT:\n";
my $res = $agent->submit();
for my $key ( $res->header_field_names() ) {
print $key, " : ", $res->header( $key ), "\n";
}
print "cookie: ".$agent->cookie_jar->as_string();
my $cUrl = '';
$cookie_jar->revert;
print "\n\n=========================================================\nGOING TO CAMPAIGN PAGE:\n";
my $res = $agent->get($cUrl);
for my $key ( $res->header_field_names() ) {
print $key, " : ", $res->header( $key ), "\n";
}
print "cookie: ".$agent->cookie_jar->as_string();
I am not sure why this worked, but I was able to resolve this by utilizing LWP::ConnCache
$agent->conn_cache(LWP::ConnCache->new());