CGI::Application, hidden form value overwritten - perl

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

Related

Put data from a text file into an HTML form

I have a text file that shows a list of currency exchanges rates.
I have read the first line of the text file content and I need this line to be inserted into the input form.
Perl
#!/usr/local/bin/perl
use strict;
use warnings;
use CGI qw(:standard);
#use Data::Dumper;
#use CGI;
my $q = CGI->new;
my %data;
$data{name} = $q->param('name');
print header;
my $file = '/admin/currencyX.txt';
open my $info, $file or die "Could not open $file: $!";
while ( my $line = <$info> ) {
print $line, "<br>";
last if $. == 1;
}
print
start_html('A Simple Example'),
h1('A Simple Example'),
start_form,
"What's your value? <br>",
textfield(-name => 'name', -class => 'nm', -value => '$line'),
p,
submit(-value => 'Add', -name => 'ed'),
end_form,
hr;
if ( $ENV{'REQUEST_METHOD'} eq "POST" ) {
if ( $data{name} eq '' ) {
print "Please provide the input";
exit;
}
#print "response " . Dumper \%data;
}
if ( param() ) {
print
"Your name is",em(param('name')),
hr;
}
print end_html;
The text file has a similar values like
Text file
AFN Afghan Afghani 73.0556951371 0.0136881868
ALL Albanian Lek 108.3423252926 0.0092300031
DZD Algerian Dinar 117.9799583224 0.0084760159
AOA Angolan Kwanza 249.2606313396 0.0040118650
ARS Argentine Peso 28.2508833695 0.0353971232
AMD Armenian Dram 482.0941933740 0.0020742834
I need a correction to make this work.
textfield(-name => 'name', -class => 'nm', -value => '$line'),
Your problem appears to be that you have put $line in single quotes - which stops it being interpolated. Try just removing them.
textfield(-name => 'name', -class => 'nm', -value => $line),
The best way to do this is to find an alternative to out putting the text value
open my $getV, '<', "/admin/currencyX.txt";
my $realV = <$getV>;
close $getV;
print $realV; # will out put AFN Afghan Afghani 73.0556951371 0.0136881868
Then append the string to a html input value
"What's your value? <br>",textfield(-name =>'name', -class =>'nm', -value =>$realV),

Error Cisco Prime HTTP GET request

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

STDOUT from Pidgin plugin script

Yesterday, I wrote a perl plugin script for Pidgin 2.10.9, running on Windows 7, and using Strawberry Perl 5.10.1.5
Basically, on the receipt of an IM, it uses backticks to call a console application (written in .NET) and returns the console output to the sender as an IM.
I had to reboot this morning, but ever since I rebooted, it has stopped working.
So, I changed the backticks to use "capture". That didn't work either, but it at least gave me this error:
(15:00:33) Plugin: Error: Error in IPC::System::Simple plumbing: "Can't dup STDOUT" - "Bad file descriptor" at (eval 12) line 53
I have no idea what's changed from yesterday to today, and wondered if anybody knew what might be causing the error?
Thanks
Edit: Thought I'd add my code
use Purple;
#use IPC::System::Simple qw(system systemx capture capturex);
use IPC::System::Simple qw(capture capturex);
%PLUGIN_INFO = (
perl_api_version => 2,
name => "PlugIn",
version => "0.1",
summary => "AutoResp",
description => "PlugIn",
author => "Mark Watkin",
url => "http://",
load => "plugin_load",
unload => "plugin_unload"
);
sub plugin_init {
return %PLUGIN_INFO;
}
sub plugin_load {
my $plugin = shift;
Purple::Debug::info("PlugIn", "plugin_load()\n");
$data = "";
$conversation_handle = Purple::Conversations::get_handle();
Purple::Signal::connect($conversation_handle, "received-im-msg", $plugin, \&signal_chat_callback, $data);
}
sub plugin_unload {
my $plugin = shift;
Purple::Debug::info("PlugIn", "plugin_unload()\n");
}
sub signal_chat_callback {
# The signal data and the user data come in as arguments
my ($account, $sender, $message, $conv, $flags) = #_;
Purple::Debug::info("PlugIn", "Account Alias \"" . $account->get_alias() . "\"\n");
if( $account->get_alias() eq "PlugIn" )
{
Purple::Debug::info("PlugIn", "Request: \"" . $message . "\"\n");
if(!$conv)
{
Purple::Debug::info("PlugIn", "No conversation\n");
$conv = Purple::Conversation->new(1, $account, $sender);
}
$im = $conv->get_im_data();
$im->send( "One moment please..." );
my $query = "";
# eval {
# $query = capture("\"D:\\SourceCode\\PlugInNET\\bin\\Debug\\PlugInNET.exe\" \"" . $message . "\"");
# #$query = capture("\"D:\\SourceCode\\PlugInNET\\bin\\Debug\\PlugInNET.exe\"", "\"" . $message . "\"");
# #my $query = capture("D:\\SourceCode\\PlugInNET\\bin\\Debug\\PlugInNET.exe");
# #my $query = `\"D:\\SourceCode\\PlugInNET\\bin\\Debug\\PlugInNET.exe\" \"$message\"`;
# #my $query = `dir /b`;
# };
# if( $# )
# {
# Purple::Debug::info("PlugIn", "Error: " . $# . "\n");
# }
Purple::Debug::info("PlugIn", "Query: " . $query . "\n");
open ( my $fh, "-|", "D:\\SourceCode\\PlugInNET\\bin\\Debug\\PlugInNET.exe \"$message\"" ) or die "Cannot run free, $ERRNO";
while (<$fh>)
{
Purple::Debug::info("PlugIn", "Read: Line " . $_ . "\n");
$query = $query . $_ . "\n";
}
close $fh;
Purple::Debug::info("PlugIn", "Query: " . $query . "\n");
if( $query eq "" )
{
$im->send( "I'm sorry, my brain doesn't seem to be functioning at the moment" );
} else {
#msgs = split(/-----------\n/, $query);
foreach( #msgs )
{
Purple::Debug::info("PlugIn", "Result Msg: \"" . $_ . "\"\n");
$im->send( "<BODY>" . $_ . "</BODY>" );
}
}
}
}
The plan was to fix up the paths once I had it working properly
Please consider using file handles instead of backticks to capture stdout from another source. You'll be able collect errors.
#!/usr/bin/perl
use strict;
use warnings;
use English;
# No taint protection in this example
open ( my $fh, '-|', '/usr/bin/free' ) or die "Cannot run free, $ERRNO";
while (<$fh>)
{
print;
}
close $fh;

BUILD Problems: Connect class chat

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;

How convert text into XML using perl?

input text file contain the following:
....
ponies B-pro
were I-pro
used I-pro
A O
report O
of O
indirect B-cd
were O
. O
...
output XML file
<sen>
<base id="pro">
<w id="1">ponies</w>
<w id="2">were</w>
<w id="3">were</w>
</base>A report of
<base id="cd">indirect</base> were
</sen>
i want to make an XML file by reading the text file, B- means the begining of my tag and I- means an include words inside the tag while "O" means outside the base tag which means it only exist in the tag.
i try the following codes:
#!/usr/local/bin/perl -w
open(my $f, "input.txt") or die "Can't";
open(my $o, ">output.xml") or die "Can't";
my $c;
sub read_line {
my $fh = shift;
if ($fh and my $line = <$fh>) {
chomp($line);
my #words = split(/\t/, $line);
my $word = $words[0];
my $group = $words[1];
if($word eq "."){
return;
}
else{
if($group ne 'O'){
my #b = split(/\-/, $group);
if($b[0] eq 'B'){
my $e = "<e id=\"";
$e .= " . $b[1] . "\">";
$e .= $word . "</e>";
return $e;
}
if($b[0] eq 'I'){
my $w = "<w id=\"";
$w .= $c . "\">";
$w .= $word . "</w>";
$c++;
return $w;
}
}
else{
$c = 2;
return $word;
}
}
}
return;
}
sub get_text(){
my $txt = "";
my $r = read_line($f);
while($r){
if($r =~ m/[[:punct:]]/){
chop($txt);
$txt .= " " . $r . " ";
}
else{
$txt .= $r . " ";
}
$r = read_line($f);
}
chop($txt);
return "<sen>" . $txt . ".</sen>";
}
instead im getting as output:
<sen>
<base id="pro"> ponies </base>
<w id="2">were</w>
<w id="3">were</w>
A report of
<base id="cd">indirect</base> were
</sen>
i really need help.
Thanks
Writing XML "by hand" will only get you in trouble. Use a module from CPAN.
In your case, I would first put the data in a proper Perl data structure (maybe a hash containing some arrays, or something similar) and then using a module (i.e. XML::Simple for starters) to output to a file.
As Javs said, you want to use a module rather than do this by hand. For your purposes, since you have mixed content, I recommend XML::LibXML. Here is an example I made to test that you can indeed to mixed content like you've got:
use XML::LibXML;
my $doc = XML::LibXML::Document->new();
my $root = $doc->createElement('html');
$doc->setDocumentElement($root);
my $body = $doc->createElement('body');
$root->appendChild($body);
my $link = $doc->createElement('a');
$link->setAttribute('href', 'http://google.com');
$link->appendText('Google');
$body->appendChild($link);
$body->appendText('Inline Text');
print $doc->toString;