File Coverage

blib/lib/Webinject.pm
Criterion Covered Total %
statement 39 41 95.1
branch n/a
condition n/a
subroutine 14 14 100.0
pod n/a
total 53 55 96.3


\n" };
line stmt bran cond sub pod time code
1             package Webinject;
2             # Copyright 2010-2012 Sven Nierlein (nierlein@cpan.org)
3             # Copyright 2004-2006 Corey Goldberg (corey@goldb.org)
4             #
5             # This file is part of WebInject.
6             #
7             # WebInject is free software; you can redistribute it and/or modify
8             # it under the terms of the GNU General Public License as published by
9             # the Free Software Foundation; either version 2 of the License, or
10             # (at your option) any later version.
11             #
12             # WebInject is distributed in the hope that it will be useful,
13             # but without any warranty; without even the implied warranty of
14             # merchantability or fitness for a particular purpose. See the
15             # GNU General Public License for more details.
16              
17 1     1   787 use 5.006;
  1         3  
18 1     1   5 use strict;
  1         2  
  1         21  
19 1     1   4 use warnings;
  1         2  
  1         28  
20 1     1   4 use Carp;
  1         10  
  1         92  
21 1     1   461 use LWP;
  1         44288  
  1         33  
22 1     1   536 use HTML::Entities;
  1         5380  
  1         80  
23 1     1   8 use URI;
  1         2  
  1         23  
24 1     1   507 use HTTP::Request::Common;
  1         1696  
  1         61  
25 1     1   485 use HTTP::Cookies;
  1         5367  
  1         30  
26 1     1   678 use XML::Simple;
  1         6628  
  1         6  
27 1     1   587 use Time::HiRes 'time', 'sleep';
  1         1173  
  1         9  
28 1     1   1018 use Getopt::Long;
  1         10852  
  1         7  
29 1     1   1077 use Crypt::SSLeay; # for SSL/HTTPS (you may comment this out if you don't need it)
  1         3365  
  1         51  
30 1     1   319 use XML::Parser; # for web services verification (you may comment this out if aren't doing XML verifications for web services)
  0            
  0            
31             use Error qw(:try); # for web services verification (you may comment this out if aren't doing XML verifications for web services)
32             use Data::Dumper; # dump hashes for debugging
33             use File::Temp qw/ tempfile /; # create temp files
34             use File::Basename;
35             use File::Spec;
36              
37             our $VERSION = '1.94';
38              
39             =head1 NAME
40              
41             Webinject - Perl Module for testing web services
42              
43             =head1 SYNOPSIS
44              
45             use Webinject;
46             my $webinject = Webinject->new();
47             $webinject->engine();
48              
49             =head1 DESCRIPTION
50              
51             WebInject is a free tool for automated testing of web applications and web
52             services. It can be used to test individual system components that have HTTP
53             interfaces (JSP, ASP, CGI, PHP, AJAX, Servlets, HTML Forms, XML/SOAP Web
54             Services, REST, etc), and can be used as a test harness to create a suite of
55             [HTTP level] automated functional, acceptance, and regression tests. A test
56             harness allows you to run many test cases and collect/report your results.
57             WebInject offers real-time results display and may also be used for monitoring
58             system response times.
59              
60             =head1 CONSTRUCTOR
61              
62             =head2 new ( [ARGS] )
63              
64             Creates an C object.
65              
66             =over 4
67              
68             =item reporttype
69              
70             possible values are 'standard', 'nagios', 'nagios2', 'mrtg' or 'external:'
71              
72             =item nooutput
73              
74             suppress all output to STDOUT, create only logfiles
75              
76             =item break_on_errors
77              
78             stop after the first testcase fails, otherwise Webinject would go on and
79             execute all tests regardless of the previous case.
80              
81             =item timeout
82              
83             Default timeout is 180seconds. Timeout starts again for every testcase.
84              
85             =item useragent
86              
87             Set the useragent used in HTTP requests. Default is 'Webinject'.
88              
89             =item max_redirect
90              
91             Set maximum number of HTTP redirects. Default is 0.
92              
93             =item proxy
94              
95             Sets a proxy which is then used for http and https requests.
96              
97             ex.: http://proxy.company.net:3128
98              
99             with authentication:
100              
101             ex.: http://user:password@proxy.company.net:3128
102              
103             =item output_dir
104              
105             Output directory where all logfiles will go to. Defaults to current directory.
106              
107             =item globalhttplog
108              
109             Can be 'yes' or 'onfail'. Will log the http request and response to a http.log file.
110              
111             =item httpauth
112              
113             Provides credentials for webserver authentications. The format is:
114              
115             ['servername', 'portnumber', 'realm-name', 'username', 'password']
116              
117             =item baseurl
118              
119             the value can be used as {BASEURL} in the test cases
120              
121             =item baseurl1
122              
123             the value can be used as {BASEURL1} in the test cases
124              
125             =item baseurl2
126              
127             the value can be used as {BASEURL2} in the test cases
128              
129             =item standaloneplot
130              
131             can be "on" or "off". Default is off.
132             Create gnuplot graphs when enabled.
133              
134             =item graphtype
135              
136             Defaults to 'lines'
137              
138             =item gnuplot
139              
140             Defines the path to your gnuplot binary.
141              
142             =item postbodybasedir
143              
144             Path to a directory from which all relative test case postbody directives
145             are based.
146              
147             When test cases include a "postbody" directive with a "file=>..."
148             value, and that value is a relative location, Webinject will prepend this
149             directory path.
150              
151             If not supplied, the directory containing the current test case file is
152             prepended to any relative "file=>" values.
153              
154             =back
155              
156             =cut
157              
158             sub new {
159             my $class = shift;
160             my (%options) = @_;
161             $| = 1; # don't buffer output to STDOUT
162              
163             my $self = {};
164             bless $self, $class;
165              
166             # set default config options
167             $self->_set_defaults();
168              
169             for my $opt_key ( keys %options ) {
170             if( exists $self->{'config'}->{$opt_key} ) {
171             if($opt_key eq 'httpauth') {
172             $self->_set_http_auth($options{$opt_key});
173             } else {
174             $self->{'config'}->{$opt_key} = $options{$opt_key};
175             }
176             }
177             else {
178             $self->_usage("ERROR: unknown option: ".$opt_key);
179             }
180             }
181              
182             # get command line options
183             $self->_getoptions();
184              
185             return $self;
186             }
187              
188             ########################################
189              
190             =head1 METHODS
191              
192             =head2 engine
193              
194             start the engine of webinject
195              
196             =cut
197              
198             sub engine {
199             #wrap the whole engine in a subroutine so it can be integrated with the gui
200             my $self = shift;
201              
202             if($self->{'gui'}) {
203             $self->_gui_initial();
204             }
205             else {
206             # delete files leftover from previous run (do this here so they are whacked each run)
207             $self->_whackoldfiles();
208             }
209              
210             $self->_processcasefile();
211              
212             # write opening tags for STDOUT.
213             $self->_writeinitialstdout();
214              
215             # create the gnuplot config file
216             $self->_plotcfg();
217              
218             # timer for entire test run
219             my $startruntimer = time();
220              
221             # process test case files named in config
222             for my $currentcasefile ( @{ $self->{'casefilelist'} } ) {
223             #print "\n$currentcasefile\n\n";
224              
225             my $configpostbodybasedir = $self->{'config'}->{'postbodybasedir'};
226             my $currentcasefilebasedir = (defined($configpostbodybasedir) ? File::Spec->canonpath($configpostbodybasedir) : undef)
227             // File::Spec->rel2abs(dirname($currentcasefile))
228             // File::Spec->rel2abs(dirname($0))
229             // File::Spec->rel2abs(dirname(__FILE__));
230            
231             my $resultfile = {
232             'name' => $currentcasefile,
233             'cases' => [],
234             };
235              
236             if($self->{'gui'}) { $self->_gui_processing_msg($currentcasefile); }
237              
238             my $tempfile = $self->_convtestcases($currentcasefile);
239              
240             my $xmltestcases;
241             eval {
242             $xmltestcases = XMLin( $tempfile,
243             varattr => 'varname',
244             variables => $self->{'config'} ); # slurp test case file to parse (and specify variables tag)
245             };
246             if($@) {
247             my $error = $@;
248             $error =~ s/^\s*//mx;
249             $self->_usage("ERROR: reading xml test case ".$currentcasefile." failed: ".$error);
250             }
251              
252             unless( defined $xmltestcases->{case} ) {
253             $self->_usage("ERROR: no test cases defined!");
254             }
255              
256             # fix case if there is only one case
257             if( defined $xmltestcases->{'case'}->{'id'} ) {
258             my $tmpcase = $xmltestcases->{'case'};
259             $xmltestcases->{'case'} = { $tmpcase->{'id'} => $tmpcase };
260             }
261              
262             #delete the temp file as soon as we are done reading it
263             if ( -e $tempfile ) { unlink $tempfile; }
264              
265             my $repeat = 1;
266             if(defined $xmltestcases->{repeat} and $xmltestcases->{repeat} > 0) {
267             $repeat = $xmltestcases->{repeat};
268             }
269              
270             my $useragent = $self->_get_useragent($xmltestcases->{case});
271              
272             for my $run_nr (1 .. $repeat) {
273              
274             # process cases in sorted order
275             for my $testnum ( sort { $a <=> $b } keys %{ $xmltestcases->{case} } ) {
276              
277             # if an XPath Node is defined, only process the single Node
278             if( $self->{'xnode'} ) {
279             $testnum = $self->{'xnode'};
280             }
281              
282             # create testcase
283             my $case = { 'id' => $testnum, 'testdir' => $currentcasefilebasedir };
284              
285             # populate variables with values from testcase file, do substitutions, and revert converted values back
286             for my $key (keys %{$xmltestcases->{'case'}->{$testnum}}) {
287             $case->{$key} = $xmltestcases->{'case'}->{$testnum}->{$key};
288             }
289              
290             my $label = '';
291             if(defined $case->{'label'}) {
292             $label = $case->{'label'}." - ";
293             }
294             $self->_out(qq|Test: $label$currentcasefile - $testnum \n|);
295              
296             $case = $self->_run_test_case($case, $useragent);
297              
298             push @{$resultfile->{'cases'}}, $case;
299              
300             # break from sub if user presses stop button in gui
301             if( $self->{'switches'}->{'stop'} eq 'yes' ) {
302             my $rc = $self->_finaltasks();
303             $self->{'switches'}->{'stop'} = 'no';
304             return $rc; # break from sub
305             }
306              
307             # break here if the last result was an error
308             if($self->{'config'}->{'break_on_errors'} and $self->{'result'}->{'iscritical'}) {
309             last;
310             }
311              
312             # if an XPath Node is defined, only process the single Node
313             if( $self->{'xnode'} ) {
314             last;
315             }
316             }
317             }
318              
319             push @{$self->{'result'}->{'files'}}, $resultfile;
320             }
321              
322             my $endruntimer = time();
323             $self->{'result'}->{'totalruntime'} = ( int( 1000 * ( $endruntimer - $startruntimer ) ) / 1000 ); #elapsed time rounded to thousandths
324              
325             # do return/cleanup tasks
326             return $self->_finaltasks();
327             }
328              
329             ################################################################################
330             # runs a single test case
331             sub _run_test_case {
332             my($self,$case,$useragent) =@_;
333              
334             confess("no testcase!") unless defined $case;
335              
336             # set some defaults
337             $case->{'id'} = 1 unless defined $case->{'id'};
338             $case->{'passedcount'} = 0;
339             $case->{'failedcount'} = 0;
340             $case->{'iswarning'} = 0;
341             $case->{'iscritical'} = 0;
342             $case->{'messages'} = [];
343              
344             $useragent = $self->_get_useragent({1 => $case}) unless defined $useragent;
345              
346             # don't do this if monitor is disabled in gui
347             if($self->{'gui'} and $self->{'monitorenabledchkbx'} ne 'monitor_off') {
348             my $curgraphtype = $self->{'config'}->{'graphtype'};
349             }
350              
351             # used to replace parsed {timestamp} with real timestamp value
352             my $timestamp = time();
353              
354             for my $key (keys %{$case}) {
355             $case->{$key} = $self->_convertbackxml($case->{$key}, $timestamp);
356             next if $key eq 'errormessage';
357             $case->{$key} = $self->_convertbackxmlresult($case->{$key});
358             }
359              
360             # replace host with realserverip in url and add http host header to useragent
361             if($self->{'config'}->{'realserverip'})
362             {
363             my($uri)=URI->new($case->{url});
364             my($host)=$uri->host();
365             $useragent->default_header('Host' => $uri->host());
366             $case->{url}=~s/\Q$host\E/$self->{'config'}->{'realserverip'}/mx;
367             }
368              
369             if( $self->{'gui'} ) { $self->_gui_tc_descript($case); }
370              
371             push @{$case->{'messages'}}, { 'html' => "" }; # HTML: open table column
372             for(qw/description1 description2/) {
373             next unless defined $case->{$_};
374             $self->_out(qq|Desc: $case->{$_}\n|);
375             push @{$case->{'messages'}}, {'key' => $_, 'value' => $case->{$_}, 'html' => "$case->{$_}
" };
376             }
377             my $method;
378             if (defined $case->{method}) {
379             $method = uc($case->{method});
380             } else {
381             $method = "GET";
382             }
383             push @{$case->{'messages'}}, { 'html' => qq|$method $case->{url}
\n| };
384              
385             push @{$case->{'messages'}}, { 'html' => "" }; # HTML: next column
386              
387             my($latency,$request,$response);
388             alarm($self->{'config'}->{'timeout'}+1); # timeout should be handled by LWP, but just in case...
389             eval {
390             local $SIG{ALRM} = sub { die("alarm") };
391             if($case->{method}){
392             if(lc $case->{method} eq "get") {
393             ($latency,$request,$response) = $self->_httpget($useragent, $case);
394             }
395             elsif(lc $case->{method} eq "delete") {
396             ($latency,$request,$response) = $self->_httpdelete($useragent, $case);
397             }
398             elsif(lc $case->{method} eq "post") {
399             ($latency,$request,$response) = $self->_httppost($useragent, $case);
400             }
401             else {
402             $self->_usage('ERROR: bad HTTP Request Method Type, you must use "get", "delete" or "post"');
403             }
404             }
405             else {
406             ($latency,$request,$response) = $self->_httpget($useragent, $case); # use "get" if no method is specified
407             }
408             };
409             alarm(0);
410             if($@) {
411             $case->{'iscritical'} = 1;
412             } else {
413             $case->{'latency'} = $latency;
414             $case->{'request'} = $request->as_string();
415             $case->{'response'} = $response->as_string();
416              
417             # verify result from http response
418             $self->_verify($response, $case);
419              
420             if($case->{verifypositivenext}) {
421             $self->{'verifylater'} = $case->{'verifypositivenext'};
422             $self->_out("Verify On Next Case: '".$case->{verifypositivenext}."' \n");
423             push @{$case->{'messages'}}, {'key' => 'verifypositivenext', 'value' => $case->{verifypositivenext}, 'html' => "Verify On Next Case: ".$case->{verifypositivenext}."
" };
424             }
425              
426             if($case->{verifynegativenext}) {
427             $self->{'verifylaterneg'} = $case->{'verifynegativenext'};
428             $self->_out("Verify Negative On Next Case: '".$case->{verifynegativenext}."' \n");
429             push @{$case->{'messages'}}, {'key' => 'verifynegativenext', 'value' => $case->{verifynegativenext}, 'html' => "Verify Negative On Next Case: ".$case->{verifynegativenext}."
" };
430             }
431              
432             # write to http.log file
433             $self->_httplog($request, $response, $case);
434              
435             # send perf data to log file for plotting
436             $self->_plotlog($latency);
437              
438             # call the external plotter to create a graph
439             $self->_plotit();
440              
441             if( $self->{'gui'} ) {
442             $self->_gui_updatemontab(); # update monitor with the newly rendered plot graph
443             }
444              
445             $self->_parseresponse($response, $case); # grab string from response to send later
446              
447             # make parsed results available in the errormessage
448             for my $key (keys %{$case}) {
449             next unless $key eq 'errormessage';
450             $case->{$key} = $self->_convertbackxmlresult($case->{$key});
451             }
452             }
453              
454             push @{$case->{'messages'}}, { 'html' => "\n" }; # HTML: next column
455             # if any verification fails, test case is considered a failure
456             if($case->{'iscritical'}) {
457             # end result will be also critical
458             $self->{'result'}->{'iscritical'} = 1;
459              
460             push @{$case->{'messages'}}, {'key' => 'success', 'value' => 'false' };
461             if( $self->{'result'}->{'returnmessage'} ) { # Add returnmessage to the output
462             my $prefix = "case #".$case->{'id'}.": ";
463             if(defined $case->{'label'}) {
464             $prefix = $case->{'label'}." (case #".$case->{'id'}."): ";
465             }
466             $self->{'result'}->{'returnmessage'} = $prefix.$self->{'result'}->{'returnmessage'};
467             my $message = $self->{'result'}->{'returnmessage'};
468             $message = $message.' - '.$case->{errormessage} if defined $case->{errormessage};
469             push @{$case->{'messages'}}, {
470             'key' => 'result-message',
471             'value' => $message,
472             'html' => "FAILED : ".$message.""
473             };
474             $self->_out("TEST CASE FAILED : ".$message."\n");
475             }
476             # print regular error output
477             elsif ( $case->{errormessage} ) { # Add defined error message to the output
478             push @{$case->{'messages'}}, {
479             'key' => 'result-message',
480             'value' => $case->{errormessage},
481             'html' => "FAILED : ".$case->{errormessage}.""
482             };
483             $self->_out(qq|TEST CASE FAILED : $case->{errormessage}\n|);
484             }
485             else {
486             push @{$case->{'messages'}}, {
487             'key' => 'result-message',
488             'value' => 'TEST CASE FAILED',
489             'html' => "FAILED"
490             };
491             $self->_out(qq|TEST CASE FAILED\n|);
492             }
493             unless( $self->{'result'}->{'returnmessage'} ) { #(used for plugin compatibility) if it's the first error message, set it to variable
494             if( $case->{errormessage} ) {
495             $self->{'result'}->{'returnmessage'} = $case->{errormessage};
496             }
497             else {
498             $self->{'result'}->{'returnmessage'} = "Test case number ".$case->{'id'}." failed";
499             if(defined $case->{'label'}) {
500             $self->{'result'}->{'returnmessage'} = "Test case ".$case->{'label'}." (#".$case->{'id'}.") failed";
501             }
502             }
503             }
504             if( $self->{'gui'} ) {
505             $self->_gui_status_failed();
506             }
507             }
508             elsif($case->{'iswarning'}) {
509             # end result will be also warning
510             $self->{'result'}->{'iswarning'} = 1;
511              
512             push @{$case->{'messages'}}, {'key' => 'success', 'value' => 'false' };
513             if( $case->{errormessage} ) { # Add defined error message to the output
514             push @{$case->{'messages'}}, {'key' => 'result-message', 'value' => $case->{errormessage}, 'html' => "WARNED : ".$case->{errormessage}."" };
515             $self->_out(qq|TEST CASE WARNED : $case->{errormessage}\n|);
516             }
517             # print regular error output
518             else {
519             # we suppress most logging when running in a plugin mode
520             push @{$case->{'messages'}}, {'key' => 'result-message', 'value' => 'TEST CASE WARNED', 'html' => "WARNED" };
521             $self->_out(qq|TEST CASE WARNED\n|);
522             }
523             unless( $self->{'result'}->{'returnmessage'} ) { #(used for plugin compatibility) if it's the first error message, set it to variable
524             if( $case->{errormessage} ) {
525             $self->{'result'}->{'returnmessage'} = $case->{errormessage};
526             }
527             else {
528             $self->{'result'}->{'returnmessage'} = "Test case number ".$case->{'id'}." warned";
529             if(defined $case->{'label'}) {
530             $self->{'result'}->{'returnmessage'} = "Test case ".$case->{'label'}." (#".$case->{'id'}.") warned";
531             }
532             }
533              
534             }
535             if( $self->{'gui'} ) {
536             $self->_gui_status_failed();
537             }
538             }
539             else {
540             $self->_out(qq|TEST CASE PASSED\n|);
541             push @{$case->{'messages'}}, {'key' => 'success', 'value' => 'true' };
542             push @{$case->{'messages'}}, {
543             'key' => 'result-message',
544             'value' => 'TEST CASE PASSED',
545             'html' => "PASSED"
546             };
547             if( $self->{'gui'} ) {
548             $self->_gui_status_passed();
549             }
550             }
551              
552             if( $self->{'gui'} ) { $self->_gui_timer_output($latency); }
553              
554             $self->_out(qq|Response Time = $latency sec \n|);
555             $self->_out(qq|------------------------------------------------------- \n|);
556             push @{$case->{'messages'}}, {
557             'key' => 'responsetime',
558             'value' => $latency,
559             'html' => "
".$latency." sec
560              
561             $self->{'result'}->{'runcount'}++;
562             $self->{'result'}->{'totalruncount'}++;
563              
564             if( $self->{'gui'} ) {
565             # update the statusbar
566             $self->_gui_statusbar();
567             }
568              
569             if( $latency > $self->{'result'}->{'maxresponse'} ) {
570             # set max response time
571             $self->{'result'}->{'maxresponse'} = $latency;
572             }
573             if(!defined $self->{'result'}->{'minresponse'} or $latency < $self->{'result'}->{'minresponse'} ) {
574             # set min response time
575             $self->{'result'}->{'minresponse'} = $latency;
576             }
577             # keep total of response times for calculating avg
578             $self->{'result'}->{'totalresponse'} = ( $self->{'result'}->{'totalresponse'} + $latency );
579             # avg response rounded to thousands
580             $self->{'result'}->{'avgresponse'} = ( int( 1000 * ( $self->{'result'}->{'totalresponse'} / $self->{'result'}->{'totalruncount'} ) ) / 1000 );
581              
582             if( $self->{'gui'} ) {
583             # update timers and counts in monitor tab
584             $self->_gui_updatemonstats();
585             }
586              
587              
588             # if a sleep value is set in the test case, sleep that amount
589             if( $case->{sleep} ) {
590             sleep( $case->{sleep} );
591             }
592              
593             $self->{'result'}->{'totalpassedcount'} += $case->{'passedcount'};
594             $self->{'result'}->{'totalfailedcount'} += $case->{'failedcount'};
595              
596             if($case->{'iscritical'} or $case->{'iswarning'}) {
597             $self->{'result'}->{'totalcasesfailedcount'}++;
598             } else {
599             $self->{'result'}->{'totalcasespassedcount'}++;
600             }
601              
602             return $case;
603             }
604              
605             ################################################################################
606             sub _get_useragent {
607             my($self, $testcases) = @_;
608              
609             # keepalive is required for ntml authentication but breaks
610             # https proxy support, so try determince which one we need
611             my $keepalive = 1;
612             if($testcases and $self->{'config'}->{'proxy'}) {
613             for my $nr (keys %{$testcases}) {
614             if($testcases->{$nr}->{'url'} =~ m/^https/gmx) {
615             $keepalive = 0;
616             }
617             }
618             }
619             my $useragent = LWP::UserAgent->new(keep_alive=>$keepalive);
620              
621             # store cookies in our LWP object
622             my($fh, $cookietempfilename) = tempfile();
623             unlink ($cookietempfilename);
624             $useragent->cookie_jar(HTTP::Cookies->new(
625             file => $cookietempfilename,
626             autosave => 1,
627             ));
628             push @{$self->{'tmpfiles'}}, $cookietempfilename;
629              
630             # http useragent that will show up in webserver logs
631             unless(defined $self->{'config'}->{'useragent'}) {
632             $useragent->agent('WebInject');
633             } else {
634             $useragent->agent($self->{'config'}->{'useragent'});
635             }
636              
637             # add proxy support if it is set in config.xml
638             if( $self->{'config'}->{'proxy'} ) {
639             # try IO::Socket::SSL first
640             eval {
641             require IO::Socket::SSL;
642             IO::Socket::SSL->import();
643             };
644             my $proxy = $self->{'config'}->{'proxy'};
645             $proxy =~ s/^http(s|):\/\///mx;
646             # http just works
647             $useragent->proxy('http', 'http://'.$proxy);
648             # authentication?
649             my $proxyuser = '';
650             my $proxypass = '';
651             if($proxy =~ s/^(.*?):(.*?)@(.*)$/$3/gmx) {
652             $proxyuser = $1;
653             $proxypass = $2;
654             }
655             # ssl depends on which class we have
656             if($INC{'IO/Socket/SSL.pm'}) {
657             $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS} = "IO::Socket::SSL";
658             if($proxypass) {
659             $proxy = $proxyuser.':'.$proxypass.'@'.$proxy;
660             }
661             my $con_proxy = 'connect://'.$proxy;
662             $useragent->proxy('https', $con_proxy);
663             } else {
664             # ssl proxy only works this way, see http://community.activestate.com/forum-topic/lwp-https-requests-proxy
665             $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS} = "Net::SSL";
666             $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
667             $ENV{HTTPS_PROXY} = $proxy;
668             $ENV{HTTPS_PROXY_USERNAME} = $proxyuser;
669             $ENV{HTTPS_PROXY_PASSWORD} = $proxypass;
670             # env proxy breaks the ssl proxy above
671             #$useragent->env_proxy();
672             }
673             }
674              
675             # don't follow redirects unless set by config
676             push @{$useragent->requests_redirectable}, 'POST';
677             $useragent->max_redirect($self->{'config'}->{'max_redirect'});
678              
679             # add http basic authentication support
680             # corresponds to:
681             # $useragent->credentials('servername:portnumber', 'realm-name', 'username' => 'password');
682             if(scalar @{$self->{'config'}->{'httpauth'}}) {
683             # add the credentials to the user agent here. The foreach gives the reference to the tuple ($elem), and we
684             # deref $elem to get the array elements.
685             for my $elem ( @{ $self->{'config'}->{'httpauth'} } ) {
686             #print "adding credential: $elem->[0]:$elem->[1], $elem->[2], $elem->[3] => $elem->[4]\n";
687             $useragent->credentials( $elem->[0].":".$elem->[1], $elem->[2], $elem->[3] => $elem->[4] );
688             }
689             }
690              
691             # change response delay timeout in seconds if it is set in config.xml
692             if($self->{'config'}->{'timeout'}) {
693             $useragent->timeout($self->{'config'}->{'timeout'}); # default LWP timeout is 180 secs.
694             }
695              
696             return $useragent;
697             }
698              
699             ################################################################################
700             # set defaults
701             sub _set_defaults {
702             my $self = shift;
703             $self->{'config'} = {
704             'currentdatetime' => scalar localtime time, #get current date and time for results report
705             'standaloneplot' => 'off',
706             'graphtype' => 'lines',
707             'httpauth' => [],
708             'reporttype' => 'standard',
709             'output_dir' => './',
710             'nooutput' => undef,
711             'realserverip' => '',
712             'baseurl' => '',
713             'baseurl1' => '',
714             'baseurl2' => '',
715             'break_on_errors' => 0,
716             'max_redirect' => 0,
717             'globalhttplog' => 'no',
718             'proxy' => '',
719             'timeout' => 180,
720             'tmpfiles' => [],
721             'postbodybasedir' => undef
722             };
723             $self->{'exit_codes'} = {
724             'UNKNOWN' => 3,
725             'OK' => 0,
726             'WARNING' => 1,
727             'CRITICAL' => 2,
728             };
729             $self->{'switches'} = {
730             'stop' => 'no',
731             'plotclear' => 'no',
732             };
733             $self->{'out'} = '';
734             $self->_reset_result();
735             return;
736             }
737              
738             ################################################################################
739             # reset result
740             sub _reset_result {
741             my $self = shift;
742             $self->{'result'} = {
743             'cases' => [],
744             'returnmessage' => undef,
745             'totalcasesfailedcount' => 0,
746             'totalcasespassedcount' => 0,
747             'totalfailedcount' => 0,
748             'totalpassedcount' => 0,
749             'totalresponse' => 0,
750             'totalruncount' => 0,
751             'totalruntime' => 0,
752             'casecount' => 0,
753             'avgresponse' => 0,
754             'iscritical' => 0,
755             'iswarning' => 0,
756             'maxresponse' => 0,
757             'minresponse' => undef,
758             'runcount' => 0,
759             };
760             return;
761             }
762              
763             ################################################################################
764             # write initial text for STDOUT
765             sub _writeinitialstdout {
766             my $self = shift;
767              
768             if($self->{'config'}->{'reporttype'} !~ /^nagios/mx) {
769             $self->_out(qq|
770             Starting WebInject Engine (v$Webinject::VERSION)...
771             |);
772             }
773             $self->_out("-------------------------------------------------------\n");
774             return;
775             }
776              
777             ################################################################################
778             # write summary and closing tags for results file
779             sub _write_result_html {
780             my $self = shift;
781              
782             my $file = $self->{'config'}->{'output_dir'}."results.html";
783             open( my $resultshtml, ">", $file )
784             or $self->_usage("ERROR: Failed to write ".$file.": ".$!);
785              
786             print $resultshtml
787             qq|
788             "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
789              
790            
791            
792             WebInject Test Results
793            
794            
811            
812            
813             \n|; \n";
814            
815             Test
816             Description
Request URL
817             Results
818             Summary
Response Time
819            
820             |;
821             for my $file (@{$self->{'result'}->{'files'}}) {
822             for my $case (@{$file->{'cases'}}) {
823             print $resultshtml qq|
$file->{'name'}
$case->{'id'}
824             for my $message (@{$case->{'messages'}}) {
825             next unless defined $message->{'html'};
826             print $resultshtml $message->{'html'} . "\n";
827             }
828             print $resultshtml "
829             }
830             }
831              
832             print $resultshtml qq|
833            
834            
835             Start Time: $self->{'config'}->{'currentdatetime'}
836             Total Run Time: $self->{'result'}->{'totalruntime'} seconds
837            
838             Test Cases Run: $self->{'result'}->{'totalruncount'}
839             Test Cases Passed: $self->{'result'}->{'totalcasespassedcount'}
840             Test Cases Failed: $self->{'result'}->{'totalcasesfailedcount'}
841             Verifications Passed: $self->{'result'}->{'totalpassedcount'}
842             Verifications Failed: $self->{'result'}->{'totalfailedcount'}
843            
844             Average Response Time: $self->{'result'}->{'avgresponse'} seconds
845             Max Response Time: $self->{'result'}->{'maxresponse'} seconds
846             Min Response Time: $self->{'result'}->{'minresponse'} seconds
847            
848            
849              
850            
851            
852             |;
853             close($resultshtml);
854             return;
855             }
856              
857             ################################################################################
858             # write summary and closing tags for XML results file
859             sub _write_result_xml {
860             my $self = shift;
861              
862             my $file = $self->{'config'}->{'output_dir'}."results.xml";
863             open( my $resultsxml, ">", $file )
864             or $self->_usage("ERROR: Failed to write ".$file.": ".$!);
865              
866             print $resultsxml "\n\n";
867              
868             for my $file (@{$self->{'result'}->{'files'}}) {
869             print $resultsxml " {'name'}."\">\n\n";
870             for my $case (@{$file->{'cases'}}) {
871             print $resultsxml " {'id'}."\">\n";
872             for my $message (@{$case->{'messages'}}) {
873             next unless defined $message->{'key'};
874             print $resultsxml " <".$message->{'key'}.">".$message->{'value'}."{'key'}.">\n";
875             }
876             print $resultsxml " \n\n";
877             }
878             print $resultsxml " \n";
879             }
880              
881             print $resultsxml qq|
882            
883             $self->{'config'}->{'currentdatetime'}
884             $self->{'result'}->{'totalruntime'}
885             $self->{'result'}->{'totalruncount'}
886             $self->{'result'}->{'totalcasespassedcount'}
887             $self->{'result'}->{'totalcasesfailedcount'}
888             $self->{'result'}->{'totalpassedcount'}
889             $self->{'result'}->{'totalfailedcount'}
890             $self->{'result'}->{'avgresponse'}
891             $self->{'result'}->{'maxresponse'}
892             $self->{'result'}->{'minresponse'}
893            
894              
895            
896             |;
897             close($resultsxml);
898             return;
899             }
900              
901             ################################################################################
902             # write summary and closing text for STDOUT
903             sub _writefinalstdout {
904             my $self = shift;
905              
906             if($self->{'config'}->{'reporttype'} !~ /^nagios/mx) {
907             $self->_out(qq|
908             Start Time: $self->{'config'}->{'currentdatetime'}
909             Total Run Time: $self->{'result'}->{'totalruntime'} seconds
910              
911             |);
912             }
913              
914             $self->_out(qq|
915             Test Cases Run: $self->{'result'}->{'totalruncount'}
916             Test Cases Passed: $self->{'result'}->{'totalcasespassedcount'}
917             Test Cases Failed: $self->{'result'}->{'totalcasesfailedcount'}
918             Verifications Passed: $self->{'result'}->{'totalpassedcount'}
919             Verifications Failed: $self->{'result'}->{'totalfailedcount'}
920              
921             |);
922             return;
923             }
924              
925             ################################################################################
926             sub _http_defaults {
927             my $self = shift;
928             my $request = shift;
929             my $useragent = shift;
930             my $case = shift;
931              
932             # Add additional cookies to the cookie jar if specified
933             if($case->{'addcookie'}) {
934             my $cookie_jar = $useragent->cookie_jar();
935             # add cookies to the cookie jar
936             # can add multiple cookies with a pipe delimiter
937             for my $addcookie (split /\|/mx, $case->{'addcookie'}) {
938             my ($ck_version, $ck_key, $ck_val, $ck_path, $ck_domain, $ck_port, $ck_path_spec, $ck_secure, $ck_maxage, $ck_discard) = split(/,/mx, $addcookie);
939             $cookie_jar->set_cookie( $ck_version, $ck_key, $ck_val, $ck_path, $ck_domain, $ck_port, $ck_path_spec, $ck_secure, $ck_maxage, $ck_discard);
940             }
941             $cookie_jar->save();
942             $cookie_jar->add_cookie_header($request);
943             }
944              
945             # add an additional HTTP Header if specified
946             if($case->{'addheader'}) {
947             # can add multiple headers with a pipe delimiter
948             for my $addheader (split /\|/mx, $case->{'addheader'}) {
949             $addheader =~ m~(.*):\ (.*)~mx;
950             $request->header( $1 => $2 ); # using HTTP::Headers Class
951             }
952             }
953              
954             # print $self->{'request'}->as_string; print "\n\n";
955              
956             my $starttimer = time();
957             my $response = $useragent->request($request);
958             my $endtimer = time();
959             my $latency = ( int( 1000 * ( $endtimer - $starttimer ) ) / 1000 ); # elapsed time rounded to thousandths
960             # print $response->as_string; print "\n\n";
961              
962             return($latency,$request,$response);
963             }
964              
965             ################################################################################
966             # send http request and read response
967             sub _httpget {
968             my $self = shift;
969             my $useragent = shift;
970             my $case = shift;
971              
972             $self->_out("GET Request: ".$case->{url}."\n");
973             my $request = new HTTP::Request( 'GET', $case->{url} );
974             return $self->_http_defaults($request, $useragent, $case);
975             }
976              
977             ################################################################################
978             # send http request and read response
979             sub _httpdelete {
980             my $self = shift;
981             my $useragent = shift;
982             my $case = shift;
983              
984             $self->_out("DELETE Request: ".$case->{url}."\n");
985             my $request = new HTTP::Request( 'DELETE', $case->{url} );
986             return $self->_http_defaults($request, $useragent, $case);
987             }
988              
989             ################################################################################
990             # post request based on specified encoding
991             sub _httppost {
992             my $self = shift;
993             my $useragent = shift;
994             my $case = shift;
995              
996             if($case->{posttype} ) {
997             if( ($case->{posttype} =~ m~application/x\-www\-form\-urlencoded~mx)
998             or ($case->{posttype} =~ m~application/json~mx)
999             )
1000             {
1001             return $self->_httppost_form_urlencoded($useragent, $case);
1002             }
1003             elsif($case->{posttype} =~ m~multipart/form\-data~mx) {
1004             return $self->_httppost_form_data($useragent, $case);
1005             }
1006             elsif( ($case->{posttype} =~ m~text/xml~mx)
1007             or ($case->{posttype} =~ m~application/soap\+xml~mx)
1008             )
1009             {
1010             return $self->_httppost_xml($useragent, $case);
1011             }
1012             else {
1013             $self->_usage('ERROR: Bad Form Encoding Type, I only accept "application/x-www-form-urlencoded", "multipart/form-data", "text/xml", "application/soap+xml"');
1014             }
1015             }
1016             else {
1017             # use "x-www-form-urlencoded" if no encoding is specified
1018             $case->{posttype} = 'application/x-www-form-urlencoded';
1019             return $self->_httppost_form_urlencoded($useragent, $case);
1020             }
1021             return;
1022             }
1023              
1024             ################################################################################
1025             # send application/x-www-form-urlencoded HTTP request and read response
1026             sub _httppost_form_urlencoded {
1027             my $self = shift;
1028             my $useragent = shift;
1029             my $case = shift;
1030              
1031             $self->_out("POST Request: ".$case->{url}."\n");
1032             my $request = new HTTP::Request('POST', $case->{url} );
1033             $request->content_type($case->{posttype});
1034             $request->content($case->{postbody});
1035              
1036             return $self->_http_defaults($request,$useragent, $case);
1037             }
1038              
1039             ################################################################################
1040             # send text/xml HTTP request and read response
1041             sub _httppost_xml {
1042             my $self = shift;
1043             my $useragent = shift;
1044             my $case = shift;
1045              
1046             my($latency,$request,$response);
1047              
1048             # read the xml file specified in the testcase
1049             $case->{postbody} =~ m~file=>(.*)~imx;
1050             my $postbodyfile = $1;
1051             if (!(File::Spec->file_name_is_absolute($postbodyfile)) && length $case->{'testdir'}) {
1052             $postbodyfile = File::Spec->rel2abs($postbodyfile, $case->{'testdir'});
1053             }
1054             open( my $xmlbody, "<", $postbodyfile )
1055             or $self->_usage("ERROR: Failed to open text/xml file $1 (resolved to $postbodyfile): $!"); # open file handle
1056            
1057             my @xmlbody = <$xmlbody>; # read the file into an array
1058             close($xmlbody);
1059              
1060             # Get the XML input file to use PARSEDRESULT and substitute the contents
1061             my $content = $self->_convertbackxmlresult(join( " ", @xmlbody ));
1062              
1063             $self->_out("POST Request: ".$case->{url}."\n");
1064             $request = new HTTP::Request( 'POST', $case->{url} );
1065             $request->content_type($case->{posttype});
1066             $request->content( $content ); # load the contents of the file into the request body
1067              
1068             ($latency,$request,$response) = $self->_http_defaults($request, $useragent, $case);
1069              
1070             my $xmlparser = new XML::Parser;
1071             # see if the XML parses properly
1072             try {
1073             $xmlparser->parse($response->decoded_content);
1074              
1075             # print "good xml\n";
1076             push @{$case->{'messages'}}, {'key' => 'verifyxml-success', 'value' => 'true', 'html' => 'Passed XML Parser (content is well-formed)' };
1077             $self->_out("Passed XML Parser (content is well-formed) \n");
1078             $case->{'passedcount'}++;
1079              
1080             # exit try block
1081             return;
1082             }
1083             catch Error with {
1084             # get the exception object
1085             my $ex = shift;
1086             # print "bad xml\n";
1087             # we suppress most logging when running in a plugin mode
1088             if($self->{'config'}->{'reporttype'} eq 'standard') {
1089             push @{$case->{'messages'}}, {'key' => 'verifyxml-success', 'value' => 'false', 'html' => "Failed XML parser on response: ".$ex };
1090             }
1091             $self->_out("Failed XML parser on response: $ex \n");
1092             $case->{'failedcount'}++;
1093             $case->{'iscritical'} = 1;
1094             }; # <-- remember the semicolon
1095              
1096             return($latency,$request,$response);
1097             }
1098              
1099             ################################################################################
1100             # send multipart/form-data HTTP request and read response
1101             sub _httppost_form_data {
1102             my $self = shift;
1103             my $useragent = shift;
1104             my $case = shift;
1105             my %myContent_;
1106             ## no critic
1107             eval "\%myContent_ = $case->{postbody}";
1108             ## use critic
1109              
1110             $self->_out("POST Request: ".$case->{url}."\n");
1111             my $request = POST($case->{url},
1112             Content_Type => $case->{posttype},
1113             Content => \%myContent_);
1114              
1115             return $self->_http_defaults($request, $useragent, $case);
1116             }
1117              
1118             ################################################################################
1119             # do verification of http response and print status to HTML/XML/STDOUT/UI
1120             sub _verify {
1121             my $self = shift;
1122             my $response = shift;
1123             my $case = shift;
1124              
1125             confess("no response") unless defined $response;
1126             confess("no case") unless defined $case;
1127              
1128             if( $case->{verifyresponsecode} ) {
1129             $self->_out(qq|Verify Response Code: "$case->{verifyresponsecode}" \n|);
1130             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode', 'value' => $case->{verifyresponsecode} };
1131              
1132             # verify returned HTTP response code matches verifyresponsecode set in test case
1133             if ( $case->{verifyresponsecode} == $response->code() ) {
1134             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-success', 'value' => 'true', 'html' => 'Passed HTTP Response Code: '.$case->{verifyresponsecode} };
1135             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-messages', 'value' => 'Passed HTTP Response Code Verification' };
1136             $self->_out(qq|Passed HTTP Response Code Verification \n|);
1137             $case->{'passedcount'}++;
1138             }
1139             else {
1140             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-success', 'value' => 'false', 'html' => 'Failed HTTP Response Code: received '.$response->code().', expecting '.$case->{verifyresponsecode} };
1141             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-messages', 'value' => 'Failed HTTP Response Code Verification (received '.$response->code().', expecting '.$case->{verifyresponsecode}.')' };
1142             $self->_out(qq|Failed HTTP Response Code Verification (received |.$response->code().qq|, expecting $case->{verifyresponsecode}) \n|);
1143             $case->{'failedcount'}++;
1144             $case->{'iscritical'} = 1;
1145              
1146             if($self->{'config'}->{'break_on_errors'}) {
1147             $self->{'result'}->{'returnmessage'} = 'Failed HTTP Response Code Verification (received '.$response->code().', expecting '.$case->{verifyresponsecode}.')';
1148             return;
1149             }
1150             }
1151             }
1152             else {
1153             # verify http response code is in the 100-399 range
1154             if($response->as_string() =~ /HTTP\/1.(0|1)\ (1|2|3)/imx ) { # verify existance of string in response
1155             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-success', 'value' => 'true', 'html' => 'Passed HTTP Response Code Verification (not in error range)' };
1156             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-messages', 'value' => 'Passed HTTP Response Code Verification (not in error range)' };
1157             $self->_out(qq|Passed HTTP Response Code Verification (not in error range) \n|);
1158              
1159             # succesful response codes: 100-399
1160             $case->{'passedcount'}++;
1161             }
1162             else {
1163             $response->as_string() =~ /(HTTP\/1.)(.*)/mxi;
1164             if($1) { #this is true if an HTTP response returned
1165             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-success', 'value' => 'false', 'html' => 'Failed HTTP Response Code Verification ('.$1.$2.')' };
1166             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-messages', 'value' => 'Failed HTTP Response Code Verification ('.$1.$2.')' };
1167             $self->_out("Failed HTTP Response Code Verification ($1$2) \n"); #($1$2) is HTTP response code
1168              
1169             $case->{'failedcount'}++;
1170             $case->{'iscritical'} = 1;
1171              
1172             if($self->{'config'}->{'break_on_errors'}) {
1173             $self->{'result'}->{'returnmessage'} = 'Failed HTTP Response Code Verification ('.$1.$2.')';
1174             return;
1175             }
1176             }
1177             #no HTTP response returned.. could be error in connection, bad hostname/address, or can not connect to web server
1178             else
1179             {
1180             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-success', 'value' => 'false', 'html' => 'Failed - No Response' };
1181             push @{$case->{'messages'}}, {'key' => 'verifyresponsecode-messages', 'value' => 'Failed - No Response' };
1182             $self->_out("Failed - No valid HTTP response:\n".$response->as_string());
1183              
1184             $case->{'failedcount'}++;
1185             $case->{'iscritical'} = 1;
1186              
1187             if($self->{'config'}->{'break_on_errors'}) {
1188             $self->{'result'}->{'returnmessage'} = 'Failed - No valid HTTP response: '.$response->as_string();
1189             return;
1190             }
1191             }
1192             }
1193             }
1194             push @{$case->{'messages'}}, { 'html' => '
' };
1195              
1196             for my $nr ('', 1..1000) {
1197             my $key = "verifypositive".$nr;
1198             if( $case->{$key} ) {
1199             $self->_out("Verify: '".$case->{$key}."' \n");
1200             push @{$case->{'messages'}}, {'key' => $key, 'value' => $case->{$key} };
1201             my $regex = $self->_fix_regex($case->{$key});
1202             # verify existence of string in response
1203             if( $response->as_string() =~ m~$regex~simx ) {
1204             push @{$case->{'messages'}}, {'key' => $key.'-success', 'value' => 'true', 'html' => "Passed: ".$case->{$key} };
1205             $self->_out("Passed Positive Verification \n");
1206             $case->{'passedcount'}++;
1207             }
1208             else {
1209             push @{$case->{'messages'}}, {'key' => $key.'-success', 'value' => 'false', 'html' => "Failed: ".$case->{$key} };
1210             $self->_out("Failed Positive Verification \n");
1211             $case->{'failedcount'}++;
1212             $case->{'iscritical'} = 1;
1213              
1214             if($self->{'config'}->{'break_on_errors'}) {
1215             $self->{'result'}->{'returnmessage'} = 'Failed Positive Verification, can not find a string matching regex: '.$regex;
1216             return;
1217             }
1218             }
1219             push @{$case->{'messages'}}, { 'html' => '
' };
1220             }
1221             elsif($nr ne '' and $nr > 5) {
1222             last;
1223             }
1224             }
1225              
1226             for my $nr ('', 1..1000) {
1227             my $key = "verifynegative".$nr;
1228             if( $case->{$key} ) {
1229             $self->_out("Verify Negative: '".$case->{$key}."' \n");
1230             push @{$case->{'messages'}}, {'key' => $key, 'value' => $case->{$key} };
1231             my $regex = $self->_fix_regex($case->{$key});
1232             # verify existence of string in response
1233             if( $response->as_string() =~ m~$regex~simx ) {
1234             push @{$case->{'messages'}}, {'key' => $key.'-success', 'value' => 'false', 'html' => 'Failed Negative: '.$case->{$key} };
1235             $self->_out("Failed Negative Verification \n");
1236             $case->{'failedcount'}++;
1237             $case->{'iscritical'} = 1;
1238              
1239             if($self->{'config'}->{'break_on_errors'}) {
1240             $self->{'result'}->{'returnmessage'} = 'Failed Negative Verification, found regex matched string: '.$regex;
1241             return;
1242             }
1243             }
1244             else {
1245             push @{$case->{'messages'}}, {'key' => $key.'-success', 'value' => 'true', 'html' => 'Passed Negative: '.$case->{$key} };
1246             $self->_out("Passed Negative Verification \n");
1247             $case->{'passedcount'}++;
1248             }
1249             push @{$case->{'messages'}}, { 'html' => '
' };
1250             }
1251             elsif($nr ne '' and $nr > 5) {
1252             last;
1253             }
1254             }
1255              
1256             if($self->{'verifylater'}) {
1257             my $regex = $self->_fix_regex($self->{'verifylater'});
1258             # verify existence of string in response
1259             if($response->as_string() =~ m~$regex~simx ) {
1260             push @{$case->{'messages'}}, {'key' => 'verifypositivenext-success', 'value' => 'true', 'html' => 'Passed Positive Verification (verification set in previous test case)' };
1261             $self->_out("Passed Positive Verification (verification set in previous test case) \n");
1262             $case->{'passedcount'}++;
1263             }
1264             else {
1265             push @{$case->{'messages'}}, {'key' => 'verifypositivenext-success', 'value' => 'false', 'html' => 'Failed Positive Verification (verification set in previous test case)' };
1266             $self->_out("Failed Positive Verification (verification set in previous test case) \n");
1267             $case->{'failedcount'}++;
1268             $case->{'iscritical'} = 1;
1269              
1270             if($self->{'config'}->{'break_on_errors'}) {
1271             $self->{'result'}->{'returnmessage'} = 'Failed Positive Verification (verification set in previous test case), can not find a string matching regex: '.$regex;
1272             return;
1273             }
1274             }
1275             push @{$case->{'messages'}}, { 'html' => '
' };
1276             # set to null after verification
1277             delete $self->{'verifylater'};
1278             }
1279              
1280             if($self->{'verifylaterneg'}) {
1281             my $regex = $self->_fix_regex($self->{'verifylaterneg'});
1282             # verify existence of string in response
1283             if($response->as_string() =~ m~$regex~simx) {
1284             push @{$case->{'messages'}}, {'key' => 'verifynegativenext-success', 'value' => 'false', 'html' => 'Failed Negative Verification (negative verification set in previous test case)' };
1285             $self->_out("Failed Negative Verification (negative verification set in previous test case) \n");
1286             $case->{'failedcount'}++;
1287             $case->{'iscritical'} = 1;
1288              
1289             if($self->{'config'}->{'break_on_errors'}) {
1290             $self->{'result'}->{'returnmessage'} = 'Failed Negative Verification (negative verification set in previous test case), found regex matched string: '.$regex;
1291             return;
1292             }
1293             }
1294             else {
1295             push @{$case->{'messages'}}, {'key' => 'verifynegativenext-success', 'value' => 'true', 'html' => 'Passed Negative Verification (negative verification set in previous test case)' };
1296             $self->_out("Passed Negative Verification (negative verification set in previous test case) \n");
1297             $case->{'passedcount'}++;
1298             }
1299             push @{$case->{'messages'}}, { 'html' => '
' };
1300             # set to null after verification
1301             delete $self->{'verifylaterneg'};
1302             }
1303              
1304             if($case->{'warning'}) {
1305             $self->_out("Verify Warning Threshold: ".$case->{'warning'}."\n");
1306             push @{$case->{'messages'}}, {'key' => "Warning Threshold", 'value' => $case->{''} };
1307             if($case->{'latency'} > $case->{'warning'}) {
1308             push @{$case->{'messages'}}, {'key' => 'warning-success', 'value' => 'false', 'html' => "Failed Warning Threshold: ".$case->{'warning'} };
1309             $self->_out("Failed Warning Threshold \n");
1310             $case->{'failedcount'}++;
1311             $case->{'iswarning'} = 1;
1312             }
1313             else {
1314             $self->_out("Passed Warning Threshold \n");
1315             push @{$case->{'messages'}}, {'key' => 'warning-success', 'value' => 'true', 'html' => "Passed Warning Threshold: ".$case->{'warning'} };
1316             $case->{'passedcount'}++;
1317             }
1318             push @{$case->{'messages'}}, { 'html' => '
' };
1319             }
1320              
1321             if($case->{'critical'}) {
1322             $self->_out("Verify Critical Threshold: ".$case->{'critical'}."\n");
1323             push @{$case->{'messages'}}, {'key' => "Critical Threshold", 'value' => $case->{''} };
1324             if($case->{'latency'} > $case->{'critical'}) {
1325             push @{$case->{'messages'}}, {'key' => 'critical-success', 'value' => 'false', 'html' => "Failed Critical Threshold: ".$case->{'critical'} };
1326             $self->_out("Failed Critical Threshold \n");
1327             $case->{'failedcount'}++;
1328             $case->{'iscritical'} = 1;
1329             }
1330             else {
1331             $self->_out("Passed Critical Threshold \n");
1332             push @{$case->{'messages'}}, {'key' => 'critical-success', 'value' => 'true', 'html' => "Passed Critical Threshold: ".$case->{'critical'} };
1333             $case->{'passedcount'}++;
1334             }
1335             }
1336              
1337             return;
1338             }
1339              
1340             ################################################################################
1341             # parse values from responses for use in future request (for session id's, dynamic URL rewriting, etc)
1342             sub _parseresponse {
1343             my $self = shift;
1344             my $response = shift;
1345             my $case = shift;
1346              
1347             my ( $resptoparse, @parseargs );
1348             my ( $leftboundary, $rightboundary, $escape );
1349              
1350             for my $type ( qw/parseresponse parseresponse1 parseresponse2 parseresponse3 parseresponse4 parseresponse5/ ) {
1351              
1352             next unless $case->{$type};
1353              
1354             @parseargs = split( /\|/mx, $case->{$type} );
1355              
1356             $leftboundary = $parseargs[0];
1357             $rightboundary = $parseargs[1];
1358             $escape = $parseargs[2];
1359              
1360             $resptoparse = $response->as_string;
1361             ## no critic
1362             if ( $resptoparse =~ m~$leftboundary(.*?)$rightboundary~s ) {
1363             $self->{'parsedresult'}->{$type} = $1;
1364             }
1365             ## use critic
1366             elsif(!defined $case->{'parsewarning'} or $case->{'parsewarning'}) {
1367             push @{$case->{'messages'}}, {'key' => $type.'-success', 'value' => 'false', 'html' => "Failed Parseresult, cannot find $leftboundary(.*?)$rightboundary" };
1368             $self->_out("Failed Parseresult, cannot find $leftboundary(*)$rightboundary\n");
1369             $case->{'iswarning'} = 1;
1370             }
1371              
1372             if ($escape) {
1373             if ( $escape eq 'escape' ) {
1374             $self->{'parsedresult'}->{$type} =
1375             $self->_url_escape( $self->{'parsedresult'}->{$type} );
1376             }
1377             if ( $escape eq 'decode' ) {
1378             $self->{'parsedresult'}->{$type} =
1379             decode_entities( $self->{'parsedresult'}->{$type} );
1380             }
1381             }
1382              
1383             #print "\n\nParsed String: $self->{'parsedresult'}->{$type}\n\n";
1384             }
1385             return;
1386             }
1387              
1388             ################################################################################
1389             # read config.xml
1390             sub _read_config_xml {
1391             my $self = shift;
1392             my $config_file = shift;
1393              
1394             my($config, $comment_mode,@configlines);
1395              
1396             # process the config file
1397             # if -c option was set on command line, use specified config file
1398             if(defined $config_file) {
1399             open( $config, '<', $config_file )
1400             or $self->_usage("ERROR: Failed to open ".$config_file." file: ".$!);
1401             $self->{'config'}->{'exists'} = 1; # flag we are going to use a config file
1402             }
1403             # if config.xml exists in current working directory, read it
1404             elsif( -e "config.xml" ) {
1405             open( $config, '<', "config.xml" )
1406             or $self->_usage("ERROR: Failed to open config.xml file: ".$!);
1407             $self->{'config'}->{'exists'} = 1; # flag we are going to use a config file
1408             }
1409             else {
1410             # if config.xml exists in same location as binary, read it
1411             my $scriptdir = File::Spec->rel2abs(dirname($0))
1412             // File::Spec->rel2abs(dirname(__FILE__));
1413             my $confpath = File::Spec->rel2abs('config.xml', $scriptdir);
1414             if ( -e $confpath ) {
1415             open( $config, '<', $confpath )
1416             or $self->_usage("ERROR: Failed to open config.xml file: ".$!);
1417             $self->{'config'}->{'exists'} = 1; # flag we are going to use a config file
1418             }
1419             }
1420              
1421             if( $self->{'config'}->{'exists'} ) { #if we have a config file, use it
1422              
1423             my @precomment = <$config>; #read the config file into an array
1424              
1425             #remove any commented blocks from config file
1426             foreach (@precomment) {
1427             unless (m~.*~mx) { # single line comment
1428             # multi-line comments
1429             if (//mx) {
1430             $comment_mode = 1;
1431             }
1432             elsif (m~~mx) {
1433             $comment_mode = 0;
1434             }
1435             elsif ( !$comment_mode ) {
1436             push( @configlines, $_ );
1437             }
1438             }
1439             }
1440             close($config);
1441             }
1442              
1443             #grab values for constants in config file:
1444             foreach (@configlines) {
1445              
1446             for my $key (
1447             qw/realserverip baseurl baseurl1 baseurl2 gnuplot proxy timeout output_dir
1448             globaltimeout globalhttplog standaloneplot max_redirect
1449             break_on_errors useragent postbodybasedir/
1450             )
1451             {
1452              
1453             if (/<$key>/mx) {
1454             $_ =~ m~<$key>(.*)~mx;
1455             $self->{'config'}->{$key} = $1;
1456              
1457             #print "\n$_ : $self->{'config'}->{$_} \n\n";
1458             }
1459             }
1460              
1461             if (//mx) {
1462             $_ =~ m~(.*)~mx;
1463             if ( $1 ne "standard" ) {
1464             $self->{'config'}->{'reporttype'} = $1;
1465             $self->{'config'}->{'nooutput'} = "set";
1466             }
1467              
1468             #print "\nreporttype : $self->{'config'}->{'reporttype'} \n\n";
1469             }
1470              
1471             if (//mx) {
1472              
1473             $_ =~ m~(.*)~mx;
1474             $self->_set_http_auth($1);
1475              
1476             #print "\nhttpauth : @{$self->{'config'}->{'httpauth'}} \n\n";
1477             }
1478              
1479             if(//mx) {
1480             my $firstparse = $'; #print "$' \n\n";
1481             $firstparse =~ m~~mx;
1482             my $filename = $`; #string between tags will be in $filename
1483             #print "\n$filename \n\n";
1484             push @{ $self->{'casefilelist'} }, $filename; #add next filename we grab to end of array
1485             }
1486             }
1487              
1488             return;
1489             }
1490              
1491             ################################################################################
1492             # parse and set http auth config
1493             sub _set_http_auth {
1494             my $self = shift;
1495             my $confstring = shift;
1496              
1497             #each time we see an , we set @authentry to be the
1498             #array of values, then we use [] to get a reference to that array
1499             #and push that reference onto @httpauth.
1500              
1501             my @authentry = split( /:/mx, $confstring );
1502             if( scalar @authentry != 5 ) {
1503             $self->_usage("ERROR: httpauth should have 5 fields delimited by colons, got: ".$confstring);
1504             }
1505             else {
1506             push( @{ $self->{'config'}->{'httpauth'} }, [@authentry] );
1507             }
1508             # basic authentication only works with redirects enabled
1509             if($self->{'config'}->{'max_redirect'} == 0) {
1510             $self->{'config'}->{'max_redirect'}++;
1511             }
1512              
1513             return;
1514             }
1515              
1516             ################################################################################
1517             # get test case files to run (from command line or config file) and evaluate constants
1518             sub _processcasefile {
1519             # parse config file and grab values it sets
1520             my $self = shift;
1521              
1522             if( ( $#ARGV + 1 ) < 1 ) { #no command line args were passed
1523             unless( $self->{'casefilelist'}->[0] ) {
1524             if ( -e "testcases.xml" ) {
1525             # if no files are specified in config.xml, default to testcases.xml
1526             push @{ $self->{'casefilelist'} }, "testcases.xml";
1527             }
1528             else {
1529             $self->_usage("ERROR: I can't find any test case files to run.\nYou must either use a config file or pass a filename "
1530             . "on the command line if you are not using the default testcase file (testcases.xml).");
1531             }
1532             }
1533             }
1534              
1535             elsif( ( $#ARGV + 1 ) == 1 ) { # one command line arg was passed
1536             # use testcase filename passed on command line (config.xml is only used for other options)
1537             push @{ $self->{'casefilelist'} }, $ARGV[0]; # first commandline argument is the test case file, put this on the array for processing
1538             }
1539              
1540             elsif( ( $#ARGV + 1 ) == 2 ) { # two command line args were passed
1541             my $xpath = $ARGV[1];
1542             if ( $xpath =~ /\/(.*)\[/mx ) { # if the argument contains a "/" and "[", it is really an XPath
1543             $xpath =~ /(.*)\/(.*)\[(.*?)\]/mx; #if it contains XPath info, just grab the file name
1544             $self->{'xnode'} = $3; # grab the XPath Node value.. (from inside the "[]")
1545             # print "\nXPath Node is: $self->{'xnode'} \n";
1546             }
1547             else {
1548             $self->_usage("ERROR: Sorry, $xpath is not in the XPath format I was expecting, I'm ignoring it...");
1549             }
1550              
1551             # use testcase filename passed on command line (config.xml is only used for other options)
1552             push @{ $self->{'casefilelist'} }, $ARGV[0]; # first command line argument is the test case file, put this on the array for processing
1553             }
1554              
1555             elsif ( ( $#ARGV + 1 ) > 2 ) { #too many command line args were passed
1556             $self->_usage("ERROR: Too many arguments.");
1557             }
1558              
1559             #print "\ntestcase file list: @{$self->{'casefilelist'}}\n\n";
1560              
1561             return;
1562             }
1563              
1564             ################################################################################
1565             # here we do some pre-processing of the test case file and write it out to a temp file.
1566             # we convert certain chars so xml parser doesn't puke.
1567             sub _convtestcases {
1568             my $self = shift;
1569             my $currentcasefile = shift;
1570              
1571             my @xmltoconvert;
1572              
1573             my ( $fh, $tempfilename ) = tempfile();
1574             push @{$self->{'tmpfiles'}}, $tempfilename;
1575             my $filename = $currentcasefile;
1576             open( my $xmltoconvert, '<', $filename )
1577             or $self->_usage("ERROR: Failed to read test case file: ".$filename.": ".$!);
1578             # read the file into an array
1579             @xmltoconvert = <$xmltoconvert>;
1580             my $ids = {};
1581             for my $line (@xmltoconvert) {
1582              
1583             # convert escaped chars and certain reserved chars to temporary values that the parser can handle
1584             # these are converted back later in processing
1585             $line =~ s/&/{AMPERSAND}/gmx;
1586             $line =~ s/\\
1587              
1588             # convert variables to lowercase
1589             $line =~ s/(\$\{[\w\.]+\})/\L$1\E/gmx;
1590             $line =~ s/(varname=('|").*?('|"))/\L$1\E/gmx;
1591              
1592             # count cases while we are here
1593             if ( $line =~ /
1594             $self->{'result'}->{'casecount'}++;
1595             }
1596              
1597             # verify id is only use once per file
1598             if ( $line =~ /^\s*id\s*=\s*\"*(\d+)\"*/mx ) {
1599             if(defined $ids->{$1}) {
1600             $self->{'result'}->{'iswarning'} = 1;
1601             $self->_out("Warning: case id $1 is used more than once!\n");
1602             }
1603             $ids->{$1} = 1;
1604             }
1605             }
1606              
1607             close($xmltoconvert);
1608              
1609             # open file handle to temp file
1610             open( $xmltoconvert, '>', $tempfilename )
1611             or $self->_usage("ERROR: Failed to write ".$tempfilename.": ".$!);
1612             print $xmltoconvert @xmltoconvert; # overwrite file with converted array
1613             close($xmltoconvert);
1614             return $tempfilename;
1615             }
1616              
1617             ################################################################################
1618             # converts replaced xml with substitutions
1619             sub _convertbackxml {
1620             my ( $self, $string, $timestamp ) = @_;
1621             return unless defined $string;
1622             $string =~ s~{AMPERSAND}~&~gmx;
1623             $string =~ s~{LESSTHAN}~<~gmx;
1624             $string =~ s~{TIMESTAMP}~$timestamp~gmx;
1625             $string =~ s~{REALSERVERIP}~$self->{'config'}->{realserverip}~gmx;
1626             $string =~ s~{BASEURL}~$self->{'config'}->{baseurl}~gmx;
1627             $string =~ s~{BASEURL1}~$self->{'config'}->{baseurl1}~gmx;
1628             $string =~ s~{BASEURL2}~$self->{'config'}->{baseurl2}~gmx;
1629             return $string;
1630             }
1631              
1632             ################################################################################
1633             # converts replaced xml with parsed result
1634             sub _convertbackxmlresult {
1635             my ( $self, $string) = @_;
1636             return unless defined $string;
1637             $string =~ s~\{PARSEDRESULT\}~$self->{'parsedresult'}->{'parseresponse'}~gmx if defined $self->{'parsedresult'}->{'parseresponse'};
1638             for my $x (1..5) {
1639             $string =~ s~\{PARSEDRESULT$x\}~$self->{'parsedresult'}->{"parseresponse$x"}~gmx if defined $self->{'parsedresult'}->{"parseresponse$x"};
1640             }
1641             return $string;
1642             }
1643              
1644             ################################################################################
1645             # escapes difficult characters with %hexvalue
1646             sub _url_escape {
1647             my ( $self, @values ) = @_;
1648              
1649             # LWP handles url encoding already, but use this to escape valid chars that LWP won't convert (like +)
1650             my @return;
1651             for my $val (@values) {
1652             $val =~ s/[^-\w.,!~'()\/\ ]/uc sprintf "%%%02x", ord $&/egmx if defined $val;
1653             push @return, $val;
1654             }
1655             return wantarray ? @return : $return[0];
1656             }
1657              
1658             ################################################################################
1659             # write requests and responses to http.log file
1660             sub _httplog {
1661             my $self = shift;
1662             my $request = shift;
1663             my $response = shift;
1664             my $case = shift;
1665             my $output = '';
1666              
1667             # http request - log setting per test case
1668             if($case->{'logrequest'} && $case->{'logrequest'} =~ /yes/mxi ) {
1669             $output .= $request->as_string."\n\n";
1670             }
1671              
1672             # http response - log setting per test case
1673             if($case->{'logresponse'} && $case->{'logresponse'} =~ /yes/mxi ) {
1674             $output .= $response->as_string."\n\n";
1675             }
1676              
1677             # global http log setting
1678             if($self->{'config'}->{'globalhttplog'} && $self->{'config'}->{'globalhttplog'} =~ /yes/mxi ) {
1679             $output .= $request->as_string."\n\n";
1680             $output .= $response->as_string."\n\n";
1681             }
1682              
1683             # global http log setting - onfail mode
1684             if($self->{'config'}->{'globalhttplog'} && $self->{'config'}->{'globalhttplog'} =~ /onfail/mxi && $case->{'iscritical'}) {
1685             $output .= $request->as_string."\n\n";
1686             $output .= $response->as_string."\n\n";
1687             }
1688              
1689             if($output ne '') {
1690             my $file = $self->{'config'}->{'output_dir'}."http.log";
1691             open( my $httplogfile, ">>", $file )
1692             or $self->_usage("ERROR: Failed to write ".$file.": ".$!);
1693             print $httplogfile $output;
1694             print $httplogfile "\n************************* LOG SEPARATOR *************************\n\n\n";
1695             close($httplogfile);
1696             }
1697              
1698             return;
1699             }
1700              
1701             ################################################################################
1702             # write performance results to plot.log in the format gnuplot can use
1703             sub _plotlog {
1704             my ( $self, $value ) = @_;
1705              
1706             my ( %months, $date, $time, $mon, $mday, $hours, $min, $sec, $year );
1707              
1708             # do this unless: monitor is disabled in gui, or running standalone mode without config setting to turn on plotting
1709             if( ( $self->{'gui'} and $self->{'monitorenabledchkbx'} ne 'monitor_off')
1710             or (!$self->{'gui'} and $self->{'config'}->{'standaloneplot'} eq 'on')
1711             ) {
1712              
1713             %months = (
1714             "Jan" => 1,
1715             "Feb" => 2,
1716             "Mar" => 3,
1717             "Apr" => 4,
1718             "May" => 5,
1719             "Jun" => 6,
1720             "Jul" => 7,
1721             "Aug" => 8,
1722             "Sep" => 9,
1723             "Oct" => 10,
1724             "Nov" => 11,
1725             "Dec" => 12
1726             );
1727              
1728             $date = scalar localtime;
1729             ($mon, $mday, $hours, $min, $sec, $year) = $date =~ /\w+\ (\w+)\ +(\d+)\ (\d\d):(\d\d):(\d\d)\ (\d\d\d\d)/mx;
1730             $time = "$months{$mon} $mday $hours $min $sec $year";
1731              
1732             my $plotlog;
1733             # used to clear the graph when requested
1734             if( $self->{'switches'}->{'plotclear'} eq 'yes' ) {
1735             # open in clobber mode so log gets truncated
1736             my $file = $self->{'config'}->{'output_dir'}."plot.log";
1737             open( $plotlog, '>', $file )
1738             or $self->_usage("ERROR: Failed to write ".$file.": ".$!);
1739             $self->{'switches'}->{'plotclear'} = 'no'; # reset the value
1740             }
1741             else {
1742             my $file = $self->{'config'}->{'output_dir'}."plot.log";
1743             open( $plotlog, '>>', $file )
1744             or $self->_usage("ERROR: Failed to write ".$file.": ".$!); #open in append mode
1745             }
1746              
1747             printf $plotlog "%s %2.4f\n", $time, $value;
1748             close($plotlog);
1749             }
1750             return;
1751             }
1752              
1753             ################################################################################
1754             # create gnuplot config file
1755             sub _plotcfg {
1756             my $self = shift;
1757              
1758             # do this unless: monitor is disabled in gui, or running standalone mode without config setting to turn on plotting
1759             if( ( $self->{'gui'} and $self->{'monitorenabledchkbx'} ne 'monitor_off')
1760             or (!$self->{'gui'} and $self->{'config'}->{'standaloneplot'} eq 'on')
1761             ) {
1762             my $file = $self->{'config'}->{'output_dir'}."plot.plt";
1763             open( my $gnuplotplt, ">", $file )
1764             or _usage("ERROR: Could not open ".$file.": ".$!);
1765             print $gnuplotplt qq|
1766             set term png
1767             set output \"$self->{'config'}->{'output_dir'}plot.png\"
1768             set size 1.1,0.5
1769             set pointsize .5
1770             set xdata time
1771             set ylabel \"Response Time (seconds)\"
1772             set yrange [0:]
1773             set bmargin 2
1774             set tmargin 2
1775             set timefmt \"%m %d %H %M %S %Y\"
1776             plot \"$self->{'config'}->{'output_dir'}plot.log\" using 1:7 title \"Response Times" w $self->{'config'}->{'graphtype'}
1777             |;
1778             close($gnuplotplt);
1779              
1780             }
1781             return;
1782             }
1783              
1784             ################################################################################
1785             # do ending tasks
1786             sub _finaltasks {
1787             my $self = shift;
1788              
1789             $self->_clean_tmp_files();
1790              
1791             if ( $self->{'gui'} ) { $self->_gui_stop(); }
1792              
1793             # we suppress most logging when running in a plugin mode
1794             if($self->{'config'}->{'reporttype'} eq 'standard') {
1795             # write summary and closing tags for results file
1796             $self->_write_result_html();
1797              
1798             #write summary and closing tags for XML results file
1799             $self->_write_result_xml();
1800             }
1801              
1802             # write summary and closing tags for STDOUT
1803             $self->_writefinalstdout();
1804              
1805             #plugin modes
1806             if($self->{'config'}->{'reporttype'} ne 'standard') {
1807             # return value is set which corresponds to a monitoring program
1808             # Nagios plugin compatibility
1809             if($self->{'config'}->{'reporttype'} =~ /^nagios/mx) {
1810             # nagios perf data has following format
1811             # 'label'=value[UOM];[warn];[crit];[min];[max]
1812             my $crit = 0;
1813             if(defined $self->{'config'}->{globaltimeout}) {
1814             $crit = $self->{'config'}->{globaltimeout};
1815             }
1816             my $lastid = 0;
1817             my $perfdata = '|time='.$self->{'result'}->{'totalruntime'}.'s;0;'.$crit.';0;0';
1818             for my $file (@{$self->{'result'}->{'files'}}) {
1819             for my $case (@{$file->{'cases'}}) {
1820             my $warn = $case->{'warning'} || 0;
1821             my $crit = $case->{'critical'} || 0;
1822             my $label = $case->{'label'} || 'case'.$case->{'id'};
1823             $perfdata .= ' '.$label.'='.$case->{'latency'}.'s;'.$warn.';'.$crit.';0;0';
1824             $lastid = $case->{'id'};
1825             }
1826             }
1827             # report performance data for missed cases too
1828             for my $nr (1..($self->{'result'}->{'casecount'} - $self->{'result'}->{'totalruncount'})) {
1829             $lastid++;
1830             my $label = 'case'.$lastid;
1831             $perfdata .= ' '.$label.'=0s;0;0;0;0';
1832             }
1833              
1834             my($rc,$message);
1835             if($self->{'result'}->{'iscritical'}) {
1836             $message = "WebInject CRITICAL - ".$self->{'result'}->{'returnmessage'};
1837             $rc = $self->{'exit_codes'}->{'CRITICAL'};
1838             }
1839             elsif($self->{'result'}->{'iswarning'}) {
1840             $message = "WebInject WARNING - ".$self->{'result'}->{'returnmessage'};
1841             $rc = $self->{'exit_codes'}->{'WARNING'};
1842             }
1843             elsif( $self->{'config'}->{globaltimeout} && $self->{'result'}->{'totalruntime'} > $self->{'config'}->{globaltimeout} ) {
1844             $message = "WebInject WARNING - All tests passed successfully but global timeout (".$self->{'config'}->{globaltimeout}." seconds) has been reached";
1845             $rc = $self->{'exit_codes'}->{'WARNING'};
1846             }
1847             else {
1848             $message = "WebInject OK - All tests passed successfully in ".$self->{'result'}->{'totalruntime'}." seconds";
1849             $rc = $self->{'exit_codes'}->{'OK'};
1850             }
1851              
1852             if($self->{'result'}->{'iscritical'} or $self->{'result'}->{'iswarning'}) {
1853             $message .= "\n".$self->{'out'};
1854             $message =~ s/^\-+$//mx;
1855             }
1856             if($self->{'config'}->{'reporttype'} eq 'nagios2') {
1857             $message =~ s/\n/
/mxg;
1858             }
1859             print $message.$perfdata."\n";
1860              
1861             $self->{'result'}->{'perfdata'} = $perfdata;
1862             return $rc;
1863             }
1864              
1865             #MRTG plugin compatibility
1866             elsif( $self->{'config'}->{'reporttype'} eq 'mrtg' )
1867             { #report results in MRTG format
1868             if( $self->{'result'}->{'totalcasesfailedcount'} > 0 ) {
1869             print "$self->{'result'}->{'totalruntime'}\n$self->{'result'}->{'totalruntime'}\n\nWebInject CRITICAL - $self->{'result'}->{'returnmessage'} \n";
1870             }
1871             else {
1872             print "$self->{'result'}->{'totalruntime'}\n$self->{'result'}->{'totalruntime'}\n\nWebInject OK - All tests passed successfully in $self->{'result'}->{'totalruntime'} seconds \n";
1873             }
1874             }
1875              
1876             #External plugin. To use it, add something like that in the config file:
1877             # external:/home/webinject/Plugin.pm
1878             elsif ( $self->{'config'}->{'reporttype'} =~ /^external:(.*)/mx ) {
1879             our $webinject = $self; # set scope of $self to global, so it can be access in the external module
1880             unless( my $return = do $1 ) {
1881             croak "couldn't parse $1: $@\n" if $@;
1882             croak "couldn't do $1: $!\n" unless defined $return;
1883             croak "couldn't run $1\n" unless $return;
1884             }
1885             }
1886              
1887             else {
1888             $self->_usage("ERROR: only 'nagios', 'nagios2', 'mrtg', 'external', or 'standard' are supported reporttype values");
1889             }
1890              
1891             }
1892              
1893             return 1 if $self->{'result'}->{'totalcasesfailedcount'} > 0;
1894             return 0;
1895             }
1896              
1897             ################################################################################
1898             # delete any files leftover from previous run if they exist
1899             sub _whackoldfiles {
1900             my $self = shift;
1901              
1902             for my $file (qw/plot.log plot.plt plot.png/) {
1903             unlink $self->{'config'}->{'output_dir'}.$file if -e $self->{'config'}->{'output_dir'}.$file;
1904             }
1905              
1906             # verify files are deleted, if not give the filesystem time to delete them before continuing
1907             while (-e $self->{'config'}->{'output_dir'}."plot.log"
1908             or -e $self->{'config'}->{'output_dir'}."plot.plt"
1909             or -e $self->{'config'}->{'output_dir'}."plot.png"
1910             ) {
1911             sleep .5;
1912             }
1913             return;
1914             }
1915              
1916             ################################################################################
1917             # call the external plotter to create a graph (if we are in the appropriate mode)
1918             sub _plotit {
1919             my $self = shift;
1920              
1921             # do this unless: monitor is disabled in gui, or running standalone mode without config setting to turn on plotting
1922             if( ( $self->{'gui'} and $self->{'monitorenabledchkbx'} ne 'monitor_off')
1923             or (!$self->{'gui'} and $self->{'config'}->{'standaloneplot'} eq 'on')
1924             ) {
1925             # do this unless its being called from the gui with No Graph set
1926             unless ( $self->{'config'}->{'graphtype'} eq 'nograph' )
1927             {
1928             my $gnuplot;
1929             if(defined $self->{'config'}->{gnuplot}) {
1930             $gnuplot = $self->{'config'}->{gnuplot}
1931             }
1932             elsif($^O eq 'MSWin32') {
1933             $gnuplot = "./wgnupl32.exe";
1934             } else {
1935             $gnuplot = "/usr/bin/gnuplot";
1936             }
1937              
1938             # if gnuplot exists
1939             if( -e $gnuplot ) {
1940             system $gnuplot, $self->{'config'}->{output_dir}."plot.plt"; # plot it
1941             }
1942             elsif( $self->{'gui'} ) {
1943             # if gnuplot not specified, notify on gui
1944             $self->_gui_no_plotter_found();
1945             }
1946             }
1947             }
1948             return;
1949             }
1950              
1951             ################################################################################
1952             # fix a user supplied regex to make it compliant with mx options
1953             sub _fix_regex {
1954             my $self = shift;
1955             my $regex = shift;
1956              
1957             $regex =~ s/\\\ / /mx;
1958             $regex =~ s/\ /\\ /gmx;
1959              
1960             return $regex;
1961             }
1962              
1963             ################################################################################
1964             # command line options
1965             sub _getoptions {
1966             my $self = shift;
1967              
1968             my( @sets, $opt_version, $opt_help, $opt_configfile );
1969             Getopt::Long::Configure('bundling');
1970             my $opt_rc = GetOptions(
1971             'h|help' => \$opt_help,
1972             'v|V|version' => \$opt_version,
1973             'c|config=s' => \$opt_configfile,
1974             'o|output=s' => \$self->{'config'}->{'output_dir'},
1975             'n|no-output' => \$self->{'config'}->{'nooutput'},
1976             'r|report-type=s' => \$self->{'config'}->{'reporttype'},
1977             't|timeout=i' => \$self->{'config'}->{'timeout'},
1978             's=s' => \@sets,
1979             );
1980             if(!$opt_rc or $opt_help) {
1981             $self->_usage();
1982             }
1983             if($opt_version) {
1984             print "WebInject version $Webinject::VERSION\nFor more info: http://www.webinject.org\n";
1985             exit 3;
1986             }
1987             $self->_read_config_xml($opt_configfile);
1988             for my $set (@sets) {
1989             my ( $key, $val ) = split /=/mx, $set, 2;
1990             if($key eq 'httpauth') {
1991             $self->_set_http_auth($val);
1992             } else {
1993             $self->{'config'}->{ lc $key } = $val;
1994             }
1995             }
1996             return;
1997             }
1998              
1999             ################################################################################
2000             # _out - print text to STDOUT and save it for later retrieval
2001             sub _out {
2002             my $self = shift;
2003             my $text = shift;
2004             if($self->{'config'}->{'reporttype'} !~ /^nagios/mx and !$self->{'config'}->{'nooutput'}) {
2005             print $text;
2006             }
2007             $self->{'out'} .= $text;
2008             return;
2009             }
2010              
2011             ################################################################################
2012             # print usage
2013             sub _usage {
2014             my $self = shift;
2015             my $text = shift;
2016              
2017             print $text."\n\n" if defined $text;
2018              
2019             print <
2020             Usage:
2021             $0
2022             [-c|--config config_file]
2023             [-o|--output output_location]
2024             [-n|--no-output]
2025             [-t|--timeout]
2026             [-r|--report-type]
2027             [-s key=value]
2028             [testcase_file [XPath]]
2029             $0 --version|-v
2030             EOB
2031             exit 3;
2032             }
2033              
2034             ################################################################################
2035             # remove any tmp files
2036             sub _clean_tmp_files {
2037             my($self) = @_;
2038             for my $tmpfile (@{$self->{'tmpfiles'}}) {
2039             unlink($tmpfile);
2040             }
2041             return;
2042             }
2043              
2044             =head1 TEST CASES
2045              
2046             =head2 Parameters
2047              
2048             =over
2049              
2050             =item addcookie
2051              
2052             When added to a test case, this adds a cookie to the cookie jar prior to the test case request being sent (i.e. the test case this is attached to will include any cookies specified in this parameter). This is useful for cases where a cookie is set outside of a Set-Cookie directive in the response header. This parameter takes a comma-delimited list of fields that configure the cookie; the fields for this parameter are a direct one-to-one correllation with the parameters to the HTTP::Cookies::set_cookie method. As well, multiple cookies can be defined by separating with a '|' character as with the addheader parameter.
2053              
2054             The comma-delimited list of fields are as follows.
2055              
2056             addcookie="version,name,value,path,domain,port,path_spec,secure,maxage,discard"
2057              
2058             version - Cookie-spec version number
2059              
2060             name - Cookie name.
2061              
2062             value - Cookie value.
2063              
2064             path - The URL path where the cookie is set.
2065              
2066             domain - The domain under which the cookie is set.
2067              
2068             port - The port on which the cookie is set.
2069              
2070             path_spec - Boolean. Set if the cookie is valid only under 'path' or the entire domain.
2071              
2072             secure - Boolean. If true (1), the cookie is only sent over secure connections
2073              
2074             maxage - The time in seconds the cookie is valid for.
2075              
2076             discard - Boolean. Do not send in future requests and destroy upon the next cookie jar save.
2077              
2078             =item parseresponse
2079              
2080             Parse a string from the HTTP response for use in subsequent requests. This is mostly used for passing Session ID's, but
2081             can be applied to any case where you need to pass a dynamically generated value. It takes the arguments in the format
2082             "leftboundary|rightboundary", and an optional third argument "leftboundary|rightboundary|escape|decode" when you want
2083             to force escaping of all non-alphanumeric characters (in case there is a wrong configuration of Apache server it will
2084             push encoded HTML characters (/ = /, : = :, ... ) to the Webinject and decode serve to translate them into normal characters.
2085             See the "Session Handling and State Management - Parsing Response Data & Embedded Session ID's" section of this manual for details and examples on how to use this parameter.
2086              
2087             Note: You may need to prepend a backslash before certain reserved characters when parsing (sorry that is rather vague).
2088              
2089             Note: Newlines (\n) are also valid boundaries and are useful when you need to use the end of the line as a boundary.
2090              
2091             parseresponse1
2092             Additional parameter for response parsing.
2093              
2094             parseresponse2
2095             Additional parameter for response parsing.
2096              
2097             parseresponse3
2098             Additional parameter for response parsing.
2099              
2100             parseresponse4
2101             Additional parameter for response parsing.
2102              
2103             parseresponse5
2104             Additional parameter for response parsing.
2105              
2106             =back
2107              
2108              
2109             =head1 EXAMPLE TEST CASE
2110              
2111            
2112            
2113             id = "1"
2114             description1 = "Sample Test Case"
2115             method = "get"
2116             url = "{BASEURL}/test.jsp"
2117             verifypositive = "All tests succeded"
2118             warning = "5"
2119             critical = "15"
2120             label = "testpage"
2121             errormessage = "got error: {PARSERESPONSE}"
2122             />
2123            
2124              
2125             detailed description about the syntax of testcases can be found on the Webinject homepage.
2126              
2127              
2128             =head1 SEE ALSO
2129              
2130             For more information about webinject visit http://www.webinject.org
2131              
2132             =head1 AUTHOR
2133              
2134             Corey Goldberg, Ecorey@goldb.orgE
2135              
2136             Sven Nierlein, Enierlein@cpan.orgE
2137              
2138             =head1 COPYRIGHT AND LICENSE
2139              
2140             Copyright (C) 2010 by Sven Nierlein
2141              
2142             Copyright (C) 2004-2006 by Corey Goldberg
2143              
2144             This library is free software; you can redistribute it under the GPL2 license.
2145              
2146             =cut
2147              
2148             1;
2149             __END__