File Coverage

blib/lib/Webinject.pm
Criterion Covered Total %
statement 36 38 94.7
branch n/a
condition n/a
subroutine 13 13 100.0
pod n/a
total 49 51 96.0


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