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.
Related
I am learning Mojo, this is my first script and it works fine - that is it does what i want it to do.
use Mojo::UserAgent;
use Mojo::DOM;
use Mojo::Collection;
use strict;
use warnings;
my $ua = Mojo::UserAgent ->new;
my $dom = Mojo::DOM ->new;
$dom = $ua->get('http://lalalala....')->res->dom;
open (my $file_zlec, "> zlc2012.csv") or die "couldn't open file!";
binmode $file_zlec, ":utf8";
for my $zlec($dom->find('table.tbl_zlc')->each){
print "$i \n"; $i++;
wypisz($zlec, 'td.tbl_zlc_d1',1);
print $file_zlec"\n";
}
sub wypisz{
my $ch= $_[0]-> find($_[1])->children;
if ($_[2]==1){
my $tekst = $ch->text;
print $file_zlec "$tekst;";
}
my $href= $ch->map(attr => 'href');
if (not $href=~/lalala\.pl/g) {$href="www.lalala.pl".$href};
print $file_zlec "$href;";
}
However, a get a lot of warnings regarding "children", "text" and "attr":
'Mojo::Collection::AOUTOLOAD (..) is DEPRECATED in favor of MOJO::Collection::map at (..)'
'Stringifacation support in Mojo::Collection::AOUTOLOAD (...) is DEPRECATED in favor of Mojo::Collection::join at (..)
I thought i was doing smth wrong, but I followed the example at http://mojocasts.com/e5 EXCACTLY and got the same warnings
use Mojo::UserAgent;
my $ua = Mojo::UserAgent ->new;
print $ua->get('http://mojolicio.us')->res->dom->html->head->title;
My questions are:
1. should i worry? like i said, scripts works fine
2. if ans(1) is no, is there a way to turn this off? i can't see anything in a command line..
Okay it looks like these deprecations have been added recently. For example the AUTOLOAD deprecation was introduced at the end of October this year, and my version of Mojolicious preceded that so I wasn't seeing the messages you were getting. I've now upgraded my installation and understand the problem.
Unfortunately, the Mojolicious DEPRECATED messages are generated by the Carp module and they don't respond to the no warnings pragma. The only way I know to disable then is to set the warning handler to a null subroutine, like this
$SIG{__WARN__} == sub { };
but that is very heavy-handed as it silences all warnings instead of just the nuisance ones you are seeing.
Since the facility you are using is deprecated, it is likely to be removed from the Mojolicious suite in the near future, so it is best anyway if you learn to adopt the new standard from the outset.
The message says
Mojo::DOM::AUTOLOAD (html) is DEPRECATED in favor of Mojo::DOM::children
which means that they would prefer that you used $dom->children('html') instead of just $dom->html. But children returns a Mojo::Collection object, which is a set of nodes, so you need to select the first item of that collection. That turns
$dom->html->head->title
into the cumbersome
$dom->children('html')->first->children('head')->first->children('title')->first
so it is far better to use the at method which takes a CSS3 expression, and you can write
$dom->at('html > head > title')
which is fine, and generates no warnings. Note that it isn't an exact replacement for the children/first chain, as the entire document is being searched for a title node that is a child of a head node that is a child of an html node. But since the only place that this can occur is at the root of the document, the result is identical. Even this can be fixed by using the CSS3 item :root in place of html.
The complete program would look like this
use strict;
use warnings;
use Mojolicious;
my $ua = Mojo::UserAgent->new;
my $dom = $ua->get('http://mojolicio.us')->res->dom;
print $dom->at('html > head > title')->text;
output
Mojolicious - Perl real-time web framework
"should i worry"
You should aim to remove all warning messages that a program generates. You first need to understand exactly why you are getting them, and then you can make the choice to write your code differently or to temporarily disable the warnings once you are certain that the problem is benign.
As a guide, I disable warnings in much less than one percent of my programs. They are almost always an indication of a coding problem that can and should be resolved.
I'm not aware of how to grab the query string from the URL using Perl. I've tried a couple of ways, example:
my $qs = $ENV{'QUERY_STRING'};
my #d = split(/&/, $qs);
if ( $d[1] eq 'reports' ) {
... do something
}
and
use CGI;
my $q = CGI->new;
my $page = $q->param('page');
But am not getting the value of the key. Right now I'm manually placing in the query string, i.e. project.local/routes.cgi?page=reports but I get the following from the command line:
Use of uninitialized value $qs in split at ./routes.cgi line 23.
Use of uninitialized value $d[1] in string eq at ./routes.cgi line 25.
I'm not sure why this warning exists as it should just be undef if it doesn't exist?
How should I store and check a query string variable? I'm primarily using the routes.cgi script as a routes controller where all links point to i.e. <a href="project.local/routes.cgi?page=xx"> and then I process a template toolkit file and redirect to that page (good concept?)
Results of diagnostics:
Use of uninitialized value $qs in split at ./routes.cgi line 23 (#1)
(W uninitialized) An undefined value was used as if it were already
defined. It was interpreted as a "" or a 0, but maybe it was a mistake.
To suppress this warning assign a defined value to your variables.
Edit:
use URI qw( );
use URI::QueryParam qw( );
my $u = URI->new($base_url);
my ($p) = $u->query_param('page');
if ( $p eq 'reports' ) {
...do something
}
Man, youre fighting many days (based on your past questions) with your route.cgi. Reading thru comments and answers in your past questions, many developers already said to you: use some framework.
Now for your question(s):
Use of uninitialized value $qs in split at ./routes.cgi line 23.
Thats mean (in line, what the use diagnostics says) - the $qs variable isn't contains any value. Why the $ENV{'QUERY_STRING'}; isn't have a value is depends on your environment, but generally, you should not depend on some environment variables but on what you get from the HTTP request.
Use of uninitialized value $d[1] in string eq at ./routes.cgi line 25.
Of course, because the $qs is undefined, the split splits the nothing, and the splitted nothing is nothing too - so you get nothing to your #d array and therefore the $d[1] isn't initialised.
BTW, when you comes from the php-word (as you said in one of your questions), you should to know, than after an succesfull split of the "QUERY_STRING" at & you will get to $d[0] the value page=report and not only the report.
As #AndyLester told you, for handling URL's (getting or composing) its parts here is the URI::URL module, but you really should at least read it's description.
Ad routes: generally is better and nicer and more SEO friendly to have URLs like:
http://example.com/blog/archive/2013/12/20
and not
http://example.com/run?section=blog&action=archive&year=2014&month=12&day=20
So, for the "routes" don't use URL parameters, but the PATH_INFO. And this "philosophy" is already developed into many frameworks, like Poet+Mason, Mojolicious, Dancer and many others, or here are standalone modules for handling routes. (search MetaCPAN.org).
From my point of view, the perl web-app developemnt based on the next commands:
Install my own perl-environment (need only once)
curl -L http://install.perlbrew.pl | bash
#relog, to init the environment
perlbrew available
prelbrew install perl-5.20.0
prelbrew switch perl-5.20.0
prelbrew install-cpanm
When got my "own" perl
cpanm Poet #will install a bunch of modules
#or alternatively
cpanm Mojolicious
And from now, things are relatively easy:
cd my_development_directory
poet new myapp
cd myapp
echo 'This is my report <% localtime %>' > comps/report.mc
./bin/run.pl
and you have an running perl web-application. So, point your browser to: http://localhost:5000/report and will get
This is my report Tue Jul 29 16:09:52 2014
and alongside you will get an great debug panel and much more... (see Mason & Poet manuals)
I'm still an beginner in perl development, so other more experianced perl-monks could give you better advices.
You want to use the URI::URL module.
http://search.cpan.org/dist/URI/lib/URI/URL.pm
jm666 is correct, you really should consider using a framework. However, if you are looking to keep your module installs to a minimum, try something like this...
use strict;
use warnings;
use URI::Escape;
use Data::Dumper;
#this will catch anything after the "?", as in SomeURL?Var=111&OtherVar=QQQ
my $RequestHash;
if($ENV{"QUERY_STRING"}) {
#QUERY_STRING="id=demo:5&other=some%20text&last=more%20text"
my #TempArray=split("&", $ENV{"QUERY_STRING"});
foreach my $item (#TempArray) {
my ($Key, $Value)=split("=", uri_unescape($item)); #need to fix this to work with more than one "=" in the value
$RequestHash->{lc($Key)}=$Value; #normalize the key name to lower case - because you never know what users will do
} #end foreach
} #end query check if
print Data::Dumper::Dumper($RequestHash);
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!
I am a newb to Perl. I am writing some scripts and want to define my own print called myprint() which will print the stuff passed to it based on some flags (verbose/debug flag)
open(FD, "> /tmp/abc.txt") or die "Cannot create abc.txt file";
print FD "---Production Data---\n";
myprint "Hello - This is only a comment - debug data";
Can someone please help me with some sample code to for myprint() function?
Do you care more about writing your own logging system, or do you want to know how to put logging statements in appropriate parts of your program which you can turn off (and, incur little performance penalty when they are turned off)?
If you want a logging system that is easy to start using, but also offers a world of features which you can incrementally discover and use, Log::Log4perl is a good option. It has an easy mode, which allows you to specify the desired logging level, and emits only those logging messages that are above the desired level.
#!/usr/bin/env perl
use strict; use warnings;
use File::Temp qw(tempfile);
use Log::Log4perl qw(:easy);
Log::Log4perl->easy_init({level => $INFO});
my ($fh, $filename) = tempfile;
print $fh "---Production Data---\n";
WARN 'Wrote something somewhere somehow';
The snippet also shows a better way of opening a temporary file using File::Temp.
As for overriding the built-in print … It really isn't a good idea to fiddle with built-ins except in very specific circumstances. perldoc perlsub has a section on Overriding Built-in Functions. The accepted answer to this question lists the Perl built-ins that cannot be overridden. print is one of those.
But, then, one really does not need to override a built-in to write a logging system.
So, if an already-written logging system does not do it for you, you really seem to be asking "how do I write a function that prints stuff conditionally depending on the value of a flag?"
Here is one way:
#!/usr/bin/env perl
package My::Logger;
{
use strict; use warnings;
use Sub::Exporter -setup => {
exports => [
DEBUG => sub {
return sub {} unless $ENV{MYDEBUG};
return sub { print 'DEBUG: ' => #_ };
},
]
};
}
package main;
use strict; use warnings;
# You'd replace this with use My::Logger qw(DEBUG) if you put My::Logger
# in My/Logger.pm somewhere in your #INC
BEGIN {
My::Logger->import('DEBUG');
}
sub nicefunc {
print "Hello World!\n";
DEBUG("Isn't this a nice function?\n");
return;
}
nicefunc();
Sample usage:
$ ./yy.pl
Hello World!
$ MYDEBUG=1 ./yy.pl
Hello World!
DEBUG: Isn't this a nice function?
I wasn't going to answer this because Sinan already has the answer I'd recommend, but tonight I also happened to be working on the "Filehandle References" chapter to the upcoming Intermediate Perl. That are a couple of relevant paragraphs which I'll just copy directly without adapting them to your question:
IO::Null and IO::Interactive
Sometimes we don't want to send our output anywhere, but we are forced
to send it somewhere. In that case, we can use IO::Null to create
a filehandle that simply discards anything that we give it. It looks
and acts just like a filehandle, but does nothing:
use IO::Null;
my $null_fh = IO::Null->new;
some_printing_thing( $null_fh, #args );
Other times, we want output in some cases but not in others. If we are
logged in and running our program in our terminal, we probably want to
see lots of output. However, if we schedule the job through cron, we
probably don't care so much about the output as long as it does the job.
The IO::Interactive module is smart enough to tell the difference:
use IO::Interactive;
print { is_interactive } 'Bamboo car frame';
The is_interactive subroutine returns a filehandle. Since the
call to the subroutine is not a simple scalar variable, we surround
it with braces to tell Perl that it's the filehandle.
Now that you know about "do nothing" filehandles, you can replace some
ugly code that everyone tends to write. In some cases you want output
and in some cases you don't, so many people use a post-expression
conditional to turn off a statement in some cases:
print STDOUT "Hey, the radio's not working!" if $Debug;
Instead of that, you can assign different values to $debug_fh based
on whatever condition you want, then leave off the ugly if $Debug
at the end of every print:
use IO::Null;
my $debug_fh = $Debug ? *STDOUT : IO::Null->new;
$debug_fh->print( "Hey, the radio's not working!" );
The magic behind IO::Null might give a warning about "print() on
unopened filehandle GLOB" with the indirect object notation (e.g.
print $debug_fh) even though it works just fine. We don't get that
warning with the direct form.
Here's a scenario. You have a large amount of legacy scripts, all using a common library. Said scripts use the 'print' statement for diagnostic output. No changes are allowed to the scripts - they range far and wide, have their approvals, and have long since left the fruitful valleys of oversight and control.
Now a new need has arrived: logging must now be added to the library. This must be done automatically and transparently, without users of the standard library needing to change their scripts. Common library methods can simply have logging calls added to them; that's the easy part. The hard part lies in the fact that diagnostic output from these scripts were always displayed using the 'print' statement. This diagnostic output must be stored, but just as importantly, processed.
As an example of this processing, the library should only record the printed lines that contain the words 'warning', 'error', 'notice', or 'attention'. The below Extremely Trivial and Contrived Example Code (tm) would record some of said output:
sub CheckPrintOutput
{
my #output = #_; # args passed to print eventually find their way here.
foreach my $value (#output) {
Log->log($value) if $value =~ /warning|error|notice|attention/i;
}
}
(I'd like to avoid such issues as 'what should actually be logged', 'print shouldn't be used for diagnostics', 'perl sucks', or 'this example has the flaws x y and z'...this is greatly simplified for brevity and clarity. )
The basic problem comes down to capturing and processing data passed to print (or any perl builtin, along those lines of reasoning). Is it possible? Is there any way to do it cleanly? Are there any logging modules that have hooks to let you do it? Or is it something that should be avoided like the plague, and I should give up on ever capturing and processing the printed output?
Additional: This must run cross-platform - windows and *nix alike. The process of running the scripts must remain the same, as must the output from the script.
Additional additional: An interesting suggestion made in the comments of codelogic's answer:
You can subclass http://perldoc.perl.org/IO/Handle.html and create your
own file handle which will do the logging work. – Kamil Kisiel
This might do it, with two caveats:
1) I'd need a way to export this functionality to anyone who uses the common library. It would have to apply automatically to STDOUT and probably STDERR too.
2) the IO::Handle documentation says that you can't subclass it, and my attempts so far have been fruitless. Is there anything special needed to make sublclassing IO::Handle work? The standard 'use base 'IO::Handle' and then overriding the new/print methods seem to do nothing.
Final edit: Looks like IO::Handle is a dead end, but Tie::Handle may do it. Thanks for all the suggestions; they're all really good. I'm going to give the Tie::Handle route a try. If it causes problems I'll be back!
Addendum: Note that after working with this a bit, I found that Tie::Handle will work, if you don't do anything tricky. If you use any of the features of IO::Handle with your tied STDOUT or STDERR, it's basically a crapshoot to get them working reliably - I could not find a way to get the autoflush method of IO::Handle to work on my tied handle. If I enabled autoflush before I tied the handle it would work. If that works for you, the Tie::Handle route may be acceptable.
There are a number of built-ins that you can override (see perlsub). However, print is one of the built-ins that doesn't work this way. The difficulties of overriding print are detailed at this perlmonk's thread.
However, you can
Create a package
Tie a handle
Select this handle.
Now, a couple of people have given the basic framework, but it works out kind of like this:
package IO::Override;
use base qw<Tie::Handle>;
use Symbol qw<geniosym>;
sub TIEHANDLE { return bless geniosym, __PACKAGE__ }
sub PRINT {
shift;
# You can do pretty much anything you want here.
# And it's printing to what was STDOUT at the start.
#
print $OLD_STDOUT join( '', 'NOTICE: ', #_ );
}
tie *PRINTOUT, 'IO::Override';
our $OLD_STDOUT = select( *PRINTOUT );
You can override printf in the same manner:
sub PRINTF {
shift;
# You can do pretty much anything you want here.
# And it's printing to what was STDOUT at the start.
#
my $format = shift;
print $OLD_STDOUT join( '', 'NOTICE: ', sprintf( $format, #_ ));
}
See Tie::Handle for what all you can override of STDOUT's behavior.
You can use Perl's select to redirect STDOUT.
open my $fh, ">log.txt";
print "test1\n";
my $current_fh = select $fh;
print "test2\n";
select $current_fh;
print "test3\n";
The file handle could be anything, even a pipe to another process that post processes your log messages.
PerlIO::tee in the PerlIO::Util module seems to allows you to 'tee' the output of a file handle to multiple destinations (e.g. log processor and STDOUT).
Lots of choices. Use select() to change the filehandle that print defaults to. Or tie STDOUT. Or reopen it. Or apply an IO layer to it.
This isn't the answer to your issue but you should be able to adopt the logic for your own use. If not, maybe someone else will find it useful.
Catching malformed headers before they happen...
package PsychicSTDOUT;
use strict;
my $c = 0;
my $malformed_header = 0;
open(TRUE_STDOUT, '>', '/dev/stdout');
tie *STDOUT, __PACKAGE__, (*STDOUT);
sub TIEHANDLE {
my $class = shift;
my $handles = [#_];
bless $handles, $class;
return $handles;
}
sub PRINT {
my $class = shift;
if (!$c++ && #_[0] !~ /^content-type/i) {
my (undef, $file, $line) = caller;
print STDERR "Missing content-type in $file at line $line!!\n";
$malformed_header = 1;
}
return 0 if ($malformed_header);
return print TRUE_STDOUT #_;
}
1;
usage:
use PsychicSTDOUT;
print "content-type: text/html\n\n"; #try commenting out this line
print "<html>\n";
print "</html>\n";
You could run the script from a wrapper script that captures the original script's stdout and writes the output somewhere sensible.