using perl cgi to fetch cookies - perl

I'm trying to inspect cookie values in a cgi script; my test script looks like
#!/usr/bin/perl -w
use DBI;
use CGI qw/:standard/;
use CGI::Cookie;
my $cgiH = CGI->new;
print header;
print start_html(-title=>'Cookie Terms'), h1("Cookie Terms"), "<hr>\n";
%cookies = CGI::Cookie->fetch;
foreach $k (keys %cookies) {
my $term = "$cookies{$k}";
my $term =~ s/SubjectTerm//;
print "at $k is $term \n";
}
print end_html;
the relevant input to the script (from an HTTP GET) is
Cookie: SubjectTerm1=ponies
Cookie: SubjectTerm2=horses
(this is verified by using either fiddler or debugging the code in my delphi app). the result of my script (omitting the HTML wrapper) is either
at SubjectTerm1 is
at SubjectTerm2 is
or if I change the print statement to
print "at $k is $cookies{$k}\n";
it is
at SubjectTerm1 is SubjectTerm1=ponies; path=/
at SubjectTerm2 is SubjectTerm2=horses; path=/
What I want to arrive it is something like this
at SubjectTerm1 is ponies
at SubjectTerm2 is horses
I know I'm missing something about the hash usage but can't quite figure out what it is.
am I not addressing the %cookies hash correctly?

If you had use warnings you would see you are clobbering the $term with the line
my $term =~ s/SubjectTerm//;
Remove the my.
I think you might be able to extract the value is simply changing the assignment to
my $term = $cookies{$k}->value();
and get rid of the s/SubjectTerm//. But not sure about this sorry.

As an aside, before I answer the question, I'd strongly recommend you look at using something other than CGI.pm -- it's the best of late-90s Perl, and other than being included by default in the core perl distribution has little to recommend it.
Some more modern, more featureful alternatives include:
CGI::Application - http://cgi-app.org/
Mojolicious - http://mojolicio.us/
Dancer - http://www.perldancer.org/
Beyond that, as #Sodved says if you'd included use strict; and use warnings; at the top of your file the first of your problems -- clobbering $term by using my twice -- would have been highlighted immediately.
Once you're using the strict and warnings pragmas (and I'd say, don't leave home without them) you'll also want to change your foreach to either:
foreach (keys %cookies) {
my $term = $cookies{$_};
...
OR
foreach my $k (keys %cookies) {
my $term = $cookies{$k};
...
That is, you'll either need to declare the $k variable, or you may prefer to use Perl's built-in $_ inside the loop -- it's purely a matter of style.
Good luck!

Related

Perl: CGI redirect from multiple submit buttons

I have a small CGI Script with 2 submit buttons. I want that the current Script redirects the User to another script, depending on which submit button is pressed.
The CGi-Script:
#!/usr/bin/perl -w
# Modules
use strict;
use warnings;
use CGI;
my $q = CGI->new();
print $q->header();
print $q->submit(-name=>'button',-value => 'disable');
print $q->submit(-name=>'button',-value => 'enable');
if ($q->param('button') eq "disable"){
print $q->redirect(-uri=>"http://1.1.1.1./cgi-bin/services/switch_XXX.cgi?disable");
} elsf ($q->param('button') eq "enable"){
print $q->redirect(-uri=>"http://1.1.1.1./cgi-bin/services/switch_XXX.cgi?enable");
} else {
}
But none of the actions is actually performed. The Error-Log shows the following:
[Tue Mar 06 11:48:44 2018] [error] [client XXXX] Use of uninitialized value in string eq at /var/www/cgi-bin/test.cgi line 23.
[Tue Mar 06 11:48:44 2018] [error] [client XXXX] Use of uninitialized value in string eq at /var/www/cgi-bin/test.cgi line 26.
Could someone of you tell me what causes the error and why the redirect is not working?
Many thanks in advance!
See "Generating a redirection header" in the CGI docs: "If you use redirection like this, you should not print out a header as well."
The messages you're seeing in the log are referring to the $q->param('button') eq "disable" checks: $q->param('button') is returning undef because the field has not been submitted yet, so you're comparing "disable" to the undefined value. These are warning messages only, that you can avoid by first checking if $q->param('button') has a true value before doing the eq comparison. (Note: In other cases, one might want to use defined to check for undef, because there are some values in Perl that are defined but still false, see Truth and Falsehood - but in this case, both "disable" and "enable" are true values.)
Also, your submit buttons need to be in a <form>. And note you've got a typo with elsf. This works for me:
#!/usr/bin/env perl
use strict;
use warnings;
use CGI;
my $q = CGI->new();
if ( $q->param('button') && $q->param('button') eq "disable" ) {
print $q->redirect(-uri=>"...");
} elsif ( $q->param('button') && $q->param('button') eq "enable" ) {
print $q->redirect(-uri=>"...");
} else {
print $q->header();
print $q->start_html;
print $q->start_form;
print $q->submit(-name=>'button', -value=>'disable');
print $q->submit(-name=>'button', -value=>'enable');
print $q->end_form;
print $q->end_html;
}
If you are just starting to write web applications in Perl, I would urge you to read CGI::Alternatives and decide whether you really want to use such old technology when newer and better (and still Perl-based) alternatives are available.
However, if you decide to stick with CGI (and CGI.pm) then there are a couple of things that can make your life easier.
It's a rare CGI program that needs two CGI objects
For most CGI programs, using an object-oriented approach is overkill. You rarely need objects. CGI.pm has a, simpler, function-based approach that you can use instead. Simply, import the functions that you want to use as you load the module:
use CGI qw[param header redirect];
Then use them without creating an object first:
if (param) {
print redirect(...);
} else {
print header(...);
}
The CGI-Generation functions are a terrible idea
It's even in the documentation.
HTML Generation functions should no longer be used
All HTML generation
functions within CGI.pm are no longer being maintained. Any issues,
bugs, or patches will be rejected unless they relate to fundamentally
broken page rendering.
The rationale for this is that the HTML generation functions of CGI.pm
are an obfuscation at best and a maintenance nightmare at worst. You
should be using a template engine for better separation of concerns.
See CGI::Alternatives for an example of using CGI.pm with the
Template::Toolkit module.
These functions, and perldoc for them, are considered deprecated, they
are no longer being maintained and no fixes or features for them will
be accepted. They will, however, continue to exist in CGI.pm without
any deprecation warnings ("soft" deprecation) so you can continue to
use them if you really want to. All documentation for these functions
has been moved to CGI::HTML::Functions.
Putting your HTML into an external template is a much better idea. And it will be easier for your front-end developer to edit. Yes, I realise you probably don't have a front-end developer on your project right now - but don't you want to plan ahead?
Having said that, your program becomes something like this:
#!/usr/bin/perl
use strict;
use warnings;
use CGI qw[param header redirect];
my $disable_url = '...';
my $enable_url = '...';
if (param('button') {
if (param('button') eq 'disable') {
print redirect($disable_url);
} elsif (param('button') eq 'enable') {
print redirect($enable_url);
}
exit;
}
print header;
print $some_output_that_is_generated_from_a_template.

Input parameter for perl CGI script

I need some insight on my Perl CGI script.
First of all all this is running under webmin so i'm doing a custom module.
I'm calling a CGI Perl script passing 2 parameter from another Perl CGI. The link I'm calling is in the following format:
http://IP:8080/foobar/alat.cgi?sysinfo=xxxxxxx&SR=yyyyyyyy
The alat.cgi script look like this
#!/usr/bin/perl
use CGI qw(:standard);
ReadParse();
$q = new CGI;
my $dir = $in->param('SR');
my $s = $in->param('sysinfo');
ui_print_header(undef, $text{'edit_title'}.$dir, "");
print $dir."<br>";
print $s"<br>";
The only output I get printed is the value of $dir and $s seems to be empty.
What am I doing wrong?
As #Сухой27 said, add use strict;, but also use warnings; to the top of your script, right below the shebang (#!/usr/bin/perl) line. Those will tell you about syntax errors and other stuff where Perl is doing something other than you might intend.
With CGI (which is btw not part of the Perl core in the latest 5.22 release any more) and the object oriented approach you are tyring to take, you don't need to use ReadParse(). That is an abomination left in from Perl 4's cgilib.pl times.
I don't know what your ui_print_header function does. I'm guessing it outputs a bunch of HTML. Are you sure you defined it?
With fixing all your syntax errors and using modern syntax, your program would look like this. I'll break down what is happening for you.
#!/usr/bin/perl
use strict;
use warnings;
use CGI;
my $q = CGI->new;
my $dir = $q->param('SR');
my $s = $q->param('sysinfo');
# you need to declare this to use it below
my %text = ( edit_title => 'foo' );
# we declare this sub further down
ui_print_header(undef, $text{'edit_title'} . $dir, q{});
print $dir . '<br />';
print $s . '<br />';
sub ui_print_header {
my ( $foo, $title, $dir, $bar ) = #_;
# do stuff here...
}
Let's look at some of the things I did here.
Saying new CGI as the CGI docs suggest is fine, but since we are using the OOP way you can use the more common CGI->new. It's the same thing really, but it's consistent with the rest of the OOP Perl world and it's more clear that you are calling the new method on the CGI package.
If you have $q, keep using it. There is no $in.
Declare all your variables with my.
Declare %text so you can use $text{'edit_title'} later. Probably you imported that, or ommitted it from the code you showed us.
Declare ui_print_header(). See above.
q{} is the same as '', but it's clearer that it's an empty string.
thank you everyone for the very quick answer, and as I was suspecting I just had some silly mistake.
Adding here the corrected code that now works
#!/usr/bin/perl
# Run alat on selected sysinfo and allow display of output
#use strict;
use diagnostics;
require 'recoverpoint-lib.pl';
use CGI qw(:standard);
ReadParse();
my $q = new CGI;
my $dir = $q->param('SR');
my $s = $q->param('sysinfo');
ui_print_header(undef, $text{'edit_title'}.$dir, "");
print $dir."<br>";
print $s."<br>";
Just to clarify for some of previous answer, this is a custom module of webmin so variable $text is imported and function ui_print_header is a webmin defined one, it basically print the page header in HTML
As you enable strict and warnings you can easily know the errors.Also you should check Apache error logs, I think the script should be like this:
#!/usr/bin/perl
use CGI qw(:standard);
use strict;
use warnings;
ReadParse();
my $q = new CGI;
my $dir = $q->param('SR');
my $s = $q->param('sysinfo');
ui_print_header(undef, $text{'edit_title'}.$dir, "");
print $dir."<br>";
print $s."<br>";

How to use Term::ReadLine to retrieve command history?

I've the following script, which is almost the same of the sample in synopsis paragraph in documentation.
use strict;
use warnings;
use Term::ReadLine;
my $term = Term::ReadLine->new('My shell');
print $term, "\n";
my $prompt = "-> ";
while ( defined ($_ = $term->readline($prompt)) ) {
print $_, "\n";
$term->addhistory($_);
}
It executes with no error, but unfortunately, even if I click the Up Arrow, I only get ^[[A and no history. What am I missing?
The print $term statement prints Term::ReadLine::Stub=ARRAY(0x223d2b8).
Since we are here, I noticed it prints the prompt underlined... but I can't find in the docs anything which could prevent it. Is there any way to avoid it?
To answer the main question, you probably don't have a good Term::ReadLine library installed. you will want either 'perl-Term-ReadLine-Perl' or 'perl-Term-ReadLine-Gnu'. These are the fedora package names, but i'm sure that the ubuntu/debian names would be similar. I believe you could also get them from CPAN, but I haven't tested that. If you haven't installed the package, perl loads a dummy module that has almost no features. for this reason history was not part of it.
The underline is part of what readline calls ornaments. if you want to turn them off completely, add $term->ornaments(0); somewhere apropriate.
my rewrite of your script is as follows
#!/usr/bin/perl
use strict;
use warnings;
use Term::ReadLine; # make sure you have the gnu or perl implementation of readline isntalled
# eg: Term::ReadLine::Gnu or Term::ReadLine::Perl
my $term = Term::ReadLine->new('My shell');
my $prompt = "-> ";
$term->ornaments(0); # disable ornaments.
while ( defined ($_ = $term->readline($prompt)) ) {
print $_, "\n";
$term->addhistory($_);
}

Subroutines vs scripts in Perl

I'm fairly new to Perl and was wondering what the best practices regarding subroutines are with Perl. Can a subroutine be too big?
I'm working on a script right now, and it might need to call another script. Should I just integrate the old script into the new one in the form of a subroutine? I need to pass one argument to the script and need one return value.
I'm guessing I'd have to do some sort of black magic to get the output from the original script, so subroutine-ing it makes sense right?
Avoiding "black magic" is always a good idea when writing code. You never want to jump through hoops and come up with an unintuitive hack to solve a problem, especially if that code needs to be supported later. It happens, admittedly, and we're all guilty of it. Circumstances can weigh heavily on "just getting the darn thing to work."
The point is, the best practice is always to make the code clean and understandable. Remember, and this is especially true with Perl code in my experience, any code you wrote yourself more than a few months ago may as well have been written by someone else. So even if you're the only one who needs to support it, do yourself a favor and make it easy to read.
Don't cling to broad sweeping ideas like "favor more files over larger files" or "favor smaller methods/subroutines over larger ones" etc. Those are good guidelines to be sure, but apply the spirit of the guideline rather than the letter of it. Keep the code clean, understandable, and maintainable. If that means the occasional large file or large method/subroutine, so be it. As long as it makes sense.
A key design goal is separation of concerns. Ideally, each subroutine performs a single well-defined task. In this light, the main question revolves not around a subroutine's size but its focus. If your program requires multiple tasks, that implies multiple subroutines.
In more complex scenarios, you may end up with groups of subroutines that logically belong together. They can be organized into libraries or, even better, modules. If possible, you want to avoid a scenario where you end up with multiple scripts that need to communicate with each other, because the usual mechanism for one script to return data to another script is tedious: the first script writes to standard output and the second script must parse that output.
Several years ago I started work at a job requiring that I build a large number of command-line scripts (at least, that's how it turned out; in the beginning, it wasn't clear what we were building). I was quite inexperienced at the time and did not organize the code very well. In hindsight, I should have worked from the premise that I was writing modules rather than scripts. In other words, the real work would have been done by modules, and the scripts (the code executed by a user on the command line) would have remained very small front-ends to invoke the modules in various ways. This would have facilitated code reuse and all of that good stuff. Live and learn, right?
Another option that hasn't been mentioned yet for reusing the code in your scripts is to put common code in a module. If you put shared subroutines into a module or modules, you can keep your scripts short and focussed on what they do that is special, while isolating the common code in a easy to access and reuse form.
For example, here is a module with a few subroutines. Put this in a file called MyModule.pm:
package MyModule;
# Always do this:
use strict;
use warnings;
use IO::Handle; # For OOP filehandle stuff.
use Exporter qw(import); # This lets us export subroutines to other scripts.
# These may be exported.
our #EXPORT_OK = qw( gather_data_from_fh open_data_file );
# Automatically export everything allowed.
# Generally best to leave empty, but in some cases it makes
# sense to export a small number of subroutines automatically.
our #EXPORT = #EXPORT_OK;
# Array of directories to search for files.
our #SEARCH_PATH;
# Parse the contents of a IO::Handle object and return structured data
sub gather_data_from_fh {
my $fh = shift;
my %data;
while( my $line = $fh->readline );
# Parse the line
chomp $line;
my ($key, #values) = split $line;
$data{$key} = \#values;
}
return \%data;
}
# Search a list of directories for a file with a matching name.
# Open it and return a handle if found.
# Die otherwise
sub open_data_file {
my $file_name = shift;
for my $path ( #SEARCH_PATH, '.' ) {
my $file_path = "$path/$file_name";
next unless -e $file_path;
open my $fh, '<', $file_path
or die "Error opening '$file_path' - $!\n"
return $fh;
}
die "No matching file found in path\n";
}
1; # Need to have trailing TRUE value at end of module.
Now in script A, we take a filename to search for and process and then print formatted output:
use strict;
use warnings;
use MyModule;
# Configure which directories to search
#MyModule::SEARCH_PATH = qw( /foo/foo/rah /bar/bar/bar /eeenie/meenie/mynie/moe );
#get file name from args.
my $name = shift;
my $fh = open_data_file($name);
my $data = gather_data_from_fh($fh);
for my $key ( sort keys %$data ) {
print "$key -> ", join ', ', #{$data->{$key}};
print "\n";
}
Script B, searches for a file, parses it and then writes the parsed data structure into a YAML file.
use strict;
use warnings;
use MyModule;
use YAML qw( DumpFile );
# Configure which directories to search
#MyModule::SEARCH_PATH = qw( /da/da/da/dum /tutti/frutti/unruly /cheese/burger );
#get file names from args.
my $infile = shift;
my $outfile = shift;
my $fh = open_data_file($infile);
my $data = gather_data_from_fh($fh);
DumpFile( $outfile, $data );
Some related documentation:
perlmod - About Perl modules in general
perlmodstyle - Perl module style guide; this has very useful info.
perlnewmod - Starting a new module
Exporter - The module used to export functions in the sample code
use - the perlfunc article on use.
Some of these docs assume you will be sharing your code on CPAN. If you won't be publishing to CPAN, simply ignore the parts about signing up and uploading code.
Even if you aren't writing for CPAN, it is beneficial to use the standard tools and CPAN file structure for your module development. Following the standard allows you to use all of the tools CPAN authors use to simplify the development, testing and installation process.
I know that all this seems really complicated, but the standard tools make each step easy. Even adding unit tests to your module distribution is easy thanks to the great tools available. The payoff is huge, and well worth the time you will invest.
Sometimes it makes sense to have a separate script, sometimes it doesn't. The "black magic" isn't that complicated.
#!/usr/bin/perl
# square.pl
use strict;
use warnings;
my $input = shift;
print $input ** 2;
#!/usr/bin/perl
# sum_of_squares.pl
use strict;
use warnings;
my ($from, $to) = #ARGV;
my $sum;
for my $num ( $from .. $to ) {
$sum += `square.pl $num` // die "square.pl failed: $? $!";
}
print $sum, "\n";
Easier and better error reporting on failure is automatic with IPC::System::Simple:
#!/usr/bin/perl
# sum_of_squares.pl
use strict;
use warnings;
use IPC::System::Simple 'capture';
my ($from, $to) = #ARGV;
my $sum;
for my $num ( $from .. $to ) {
$sum += capture( "square.pl $num" );
}
print $sum, "\n";

Why does my Perl CGI program fail when I include a file?

I'm trying to create a base template which then loads data depending on what actions are taken. I included ( required ) some pages which was fine but when I included another file which I got a 500 internal error. pasting the code straight in and it works fine:
Here's what I've got;
#!/usr/bin/perl
use strict;
use warnings;
use LWP::Simple;
require LWP::UserAgent;
use DBI;
#deal with post requests
require "perl/post-sort.pl";
#loading stylesheets and javascripts
require "header.pl";
# bring in loggin js
if( $arg{REQUEST_KEY} eq "") {
require "javascript/js-main-login.pl";
}
print "</head> \n";
print " \n";
...
...
perl/post-sort.pl
my %arg = ();
for (split /\&/, <STDIN>) {
my ($key, $val) = split /=/;
$val =~ s/\+/ /g;
$val =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
$arg{$key} = $val;
}
Any help much appreciated.
A 500 internal server error often indicates a bad or missing header. Make sure that in the included code, the first thing that gets printed (to the browser) is the header, or make sure that nothing gets printed and the original code will print out the right header.
Another possibility is that a file you are require'ing does not "return true as the last statement" (i.e., doesn't end with a 1;), which would cause your script to fail at compile-time and produce a 500 error.
Also see this apropos discussion on debugging CGI scripts from earlier today.