lw.pm

一个用perl写的功能强大的cgi漏洞检测程序

		}

		push( @{$LW::forms_current{$CURRENT_SELECT}}, 

			(['option',$$hr{value},undef]) );

		delete $$hr{value};

		$parr=\@{$LW::forms_current{$CURRENT_SELECT}->[-1]};



	} elsif($TAG eq 'textarea'){

		my $stop=$start+$len;

		# find closing </textarea> tag

		do {	$stop=index($$dr,'</',$stop+2); 

			return undef if($stop==-1); # MAJOR PUKE

		} while( lc(substr($$dr,$stop+2,8)) ne 'textarea');

		$$hr{value}=substr($$dr,$start+$len,($stop-$start-$len));



		$$hr{name}='unknown'.$UNKNOWNS++ if(!defined $$hr{name});

		$key=$$hr{name};

		push( @{$LW::forms_current{$key}}, 

			(['textarea',$$hr{value},undef]) );

		$parr=\@{$LW::forms_current{$key}->[-1]};

		delete $$hr{'name'}; delete $$hr{'value'};



	} else { # button

		$$hr{name}='unknown'.$UNKNOWNS++ if(!defined $$hr{name});

		$key=$$hr{name};

		push( @{$LW::forms_current{$key}}, 

			(['button',$$hr{value},undef]) );

	}



	if(scalar %$hr){

		my @params=();

		foreach $k (keys %$hr){

			if(defined $$hr{$k}){

					push @params, "$k=\"$$hr{$k}\"";

			} else {	push @params, $k; }

		}

		$$parr[2]=\@params;

	}



	return undef;

}}



=pod



=head1 ++ Sub package: html

        

The html sub package implements a simple HTML parser.



=cut



################################################################



=pod



=head1 - Function: LW::html_find_tags

  

Params: \$data, \&callback_function [, $xml_flag]

Return: nothing



LW::html_find_tags parses a piece of HTML and 'extracts' all found tags,

passing the info to the given callback function.  The callback function 

must accept two parameters: the current tag (as a scalar), and a hash ref 

of all the tag's elements. For example, the tag <a href="/file"> will

pass 'a' as the current tag, and a hash reference which contains

{'href'}="/file".



The xml_flag, when set, causes the parser to do some extra processing

and checks to accomodate XML style tags such as <tag foo="bar"/>.



Notice: this function is slow! And using it to rewrite (via passback) is 

slower!  Make sure you have LW::bin installed to get the faster binary 

version.



=cut



sub html_find_tags {

 # use faster binary helper

 goto &LW::bin::html_find_tags 

 	if(defined $LW::available{'lw::bin'});

	

 my ($dataref, $callbackfunc, $xml)=@_;



 return if(!(defined $dataref      && ref($dataref)     ));

 return if(!(defined $callbackfunc && ref($callbackfunc)));

 $xml||=0;



 my ($CURTAG, $ELEMENT, $VALUE, $c, $cc);

 my ($INCOMMENT,$INTAG,$INSCRIPT,$INCDATA)=(0,0,0,0);

 my (%TAG, $ret, $start, $tagstart, $commstart, $scriptstart, $x);



 # YES, this looks like C.  In fact, it's my C version ported to

 # perl.  But it's faster and more dependable than any regex mess

 # someone could come up with.

 my $LEN = length($$dataref);

 for ($c=0; $c<$LEN; $c++){



	$cc=substr($$dataref,$c,1);



	next if(!$INCOMMENT && !$INTAG && !$INSCRIPT && $cc ne '>' && $cc ne '<');



        if($cc eq '<'){

		if($INSCRIPT){

			if(lc(substr($$dataref,$c+1,7)) eq '/script'){

				$INSCRIPT=0;

				$TAG{'='}=substr($$dataref, $scriptstart,

					$c - $scriptstart - 1);

			} else { next; }

		}



		next if($INCDATA); # skip tags in xml CDATA section



                if(substr($$dataref,$c+1,3) eq '!--'){

                        $INCOMMENT=1; $commstart=$c; $c+=3;



		$INCDATA++ if($xml&&substr($$dataref,$c+1,8) eq '![CDATA[');



		} else {

    	                $INTAG=1; $c++;

			$c++ while(substr($$dataref,$c,1)=~tr/< \t\r\n//);

			$tagstart=$c-1; 



			$CURTAG='';

			while(($x=substr($$dataref,$c,1))!~tr/ \t\r\n>=// &&

					$c < $LEN){

				$CURTAG.=$x; $c++;}



			chop $CURTAG if($xml && substr($CURTAG,-1,1) eq '/');

			$c++ if($x ne '>');



			$INSCRIPT=1 if($CURTAG eq 'script' && !$xml);

		}	

		$cc=substr($$dataref,$c,1); # refresh current char (cc)

	}



        if($cc eq '>'){

		if($INSCRIPT){

			if($CURTAG eq 'script'){

				$scriptstart = $c + 1; 

			} else { next; }

		}



		if($INCDATA && substr($$dataref,$c-2,2) eq ']]'){

			$INCDATA=0;

			next;

		}



		if(!$INCOMMENT && $INTAG){ 

			$INTAG=0; 

			$TAG{'/'}++ if($xml&&substr($$dataref,$c-1,1) eq '/');

			$ret=&$callbackfunc($CURTAG,\%TAG, $dataref,

				$tagstart, $c-$tagstart+1);

			$c+=$ret if(defined $ret && $ret != 0);

			$CURTAG='';

			%TAG=();

		}

                if($INCOMMENT && substr($$dataref,$c-2,2) eq '--'){

                        $INCOMMENT=0; 

			$TAG{'='}=substr($$dataref,$commstart+4,

				$c-$commstart-3);

			$ret=&$callbackfunc('!--',\%TAG, $dataref,

				$commstart, $c-$commstart+1);

			$c+=$ret if(defined $ret && $ret != 0);

			delete $TAG{'='};

			next;

		}

	}



        next if($INCOMMENT);



        if($INTAG){



                $ELEMENT=''; $VALUE='';



		# eat whitespace

		$c++ while(substr($$dataref,$c,1)=~tr/ \t\r\n//);



		$start=$c;

		$c++ while(substr($$dataref,$c,1)!~tr/ \t\r\n=\>// && $c<$LEN);



		if($c > $start){

			$ELEMENT=substr($$dataref,$start,$c-$start);

			chop $ELEMENT if($xml&&substr($ELEMENT,-1,1) eq '/');

		}



		if(substr($$dataref,$c,1) ne '>'){

		 # eat whitespace

		 $c++ while(substr($$dataref,$c,1)=~tr/ \t\r\n//);



                 if(substr($$dataref,$c,1) eq '='){ 

                	$c++;

			$start=$c;

			my $p = substr($$dataref,$c,1);

                        if($p eq '"' || $p eq '\''){ 

                        	$c++; $start++;

	                        $c++ while(substr($$dataref,$c,1) ne $p &&

	                        	$c < $LEN);

				$VALUE=substr($$dataref,$start,$c-$start);

                                $c++; 

			} else {

                                $c++ while(substr($$dataref,$c,1)!~tr/ \t\r\n\>// &&

                                	$c < $LEN);

				$VALUE=substr($$dataref,$start,$c-$start);

				chop $VALUE if($xml&&substr($$dataref,$c-1,2) eq '/>');

			}



			# eat whitespace

                	$c++ while(substr($$dataref,$c,1)=~tr/ \t\r\n//);

                 } 

		} # if $c ne '>'

		$c--;

		$TAG{$ELEMENT}=$VALUE if($ELEMENT ne '' && ($xml && $ELEMENT ne '/'));

	}

}}



################################################################



=pod



=head1 ++ Sub package: http



The http package is the core package of libwhisker.  It is responsible

for making the HTTP requests, and parsing the responses.  It can handle

HTTP 0.9, 1.0, and 1.1 requests, and allows pretty much every aspect of

the request to be configured and controlled.  The HTTP functions use a

HTTP in/out hash, which is a normal perl hash.  For outgoing HTTP requests

('hin' hashes), the keys/values represent outgoing HTTP headers.  For HTTP

responses ('hout' hashes), the keys/values represent incoming HTTP

headers.  For both, however, there is a special key, 'whisker', whose

value is a hash reference.  The whisker control hash contains more

configuration variables, which include host, port, and uri of the desired

request.  To access the whisker control hash, use the following

notation: $hash{'whisker'}->{'key'}='value';



You should view LW::http_init_request() for a list of core whisker control

hash values.



The internals of the http subpackage will be rewritten shortly--the 

current implementation is gross and not very good style.  Note that the

API will be unaffected; it will only be an internal reordering.  All

references/uses of $$Z will be cleaned up to be more practical/eliminated.



=cut



##################################################################



=pod



=head1 - Function: LW::http_init_request

   

Params: \%request_hash_to_initialize

Return: Nothing (modifies input hash)



Sets default values to the input hash for use.  Sets the host to

'localhost', port 80, request URI '/', using HTTP 1.1 with GET

method.  The timeout is set to 10 seconds, no proxies are defined, and all

URI formatting is set to standard HTTP syntax.  It also sets the

Connection (Keep-Alive) and User-Agent headers.



NOTICE!!  It's important to use http_init_request before calling 

http_do_request, or http_do_request might puke.  Thus, a special magic 

value is placed in the hash to let http_do_request know that the hash has 

been properly initialized.  If you really must 'roll your own' and not use 

http_init_request before you call http_do_request, you will at least need 

to set the INITIAL_MAGIC value (amongst other things).



=cut



sub http_init_request { # doesn't return anything

 my ($hin)=shift;



 return if(!(defined $hin && ref($hin)));

 %$hin=(); # clear control hash



# control values

 $$hin{'whisker'}={

	req_spacer		=>	' ',

	req_spacer2		=>	' ',

	http_ver		=>	'1.1',

	method			=>	'GET',

	method_postfix		=>	'',

	port			=>	80,

	uri			=>	'/',

	uri_prefix		=>	'',

	uri_postfix		=>	'',

	uri_param_sep		=>	'?',

	host			=>	'localhost',

	http_req_trailer    	=>	'',

	timeout			=>	10,

	include_host_in_uri 	=>	0,

	ignore_duplicate_headers=> 	1,

	normalize_incoming_headers =>	1,

	lowercase_incoming_headers =>	0,

	ssl			=>	0,

	http_eol		=>	"\x0d\x0a",

	force_close		=>	0,

	force_open		=>	0,

	retry			=>	1,

	trailing_slurp		=>	0,

	force_bodysnatch	=>	0,

	INITIAL_MAGIC		=>	31337

};



 

# default header values

 $$hin{'Connection'}='Keep-Alive'; # notice it is now default!

 $$hin{'User-Agent'}="libwhisker/$LW::VERSION"; # heh

}





##################################################################



=pod



=head1 - Function: LW::http_do_request

   

Params: \%request, \%response [, \%configs]

Return: >=1 if error; 0 if no error (also modifies response hash)



*THE* core function of libwhisker.  LW::http_do_request actually performs

the HTTP request, using the values submitted in %request, and placing result

values in %response.  This allows you to resubmit %request in subsequent 

requests (%response is automatically cleared upon execution).  You can 

submit 'runtime' config directives as %configs, which will be spliced into

$hin{'whisker'}->{} before anything else.  That means you can do:



LW::http_do_request(\%req,\%resp,{'uri'=>'/cgi-bin/'});



This will set $req{'whisker'}->{'uri'}='/cgi-bin/' before execution, and

provides a simple shortcut (note: it does modify %req).



This function will also retry any requests that bomb out during the 

transaction (but not during the connecting phase).  This is controlled

by the {whisker}->{retry} value.  Also note that the returned error

message in resp is the *last* error received.  All retry errors are

put into {whisker}->{retry_errors}, which is an anonymous array.



Also note that all NTLM auth logic is implemented in http_do_request().

NTLM requires multiple requests in order to work correctly, and so this

function attempts to wrap that and make it all transparent, so that the

final end result is what's passed to the application.



This function will return 0 on success, 1 on HTTP protocol error, and 2

on non-recoverable network connection error (you can retry error 1, but

error 2 means that the server is totally unreachable and there's no

point in retrying).



=cut



sub http_do_request {

 my @params = @_;

 my $retry_count = ${$params[0]}{'whisker'}->{'retry'} || 0;

 my ($ret, @retry_errors, $auth);



 return 1 if(!(defined $params[0] && ref($params[0])));

 return 1 if(!(defined $params[1] && ref($params[1])));



 if(defined $params[2]){

	foreach (keys %{$params[2]}){

		${$params[0]}{'whisker'}->{$_}=${$params[2]}{$_};}}



 $auth=$params[0]->{'Authorization'} if(defined $params[0]->{'Authorization'});

 do {

    if(defined $auth && $auth=~/^NTLM/){

	$ret=0;

	if($params[0]->{'whisker'}->{'ntlm_step'}==0){

		$ret=LW::http_do_request_ex($params[0],$params[1]);

		return 2 if($ret==2);

		if($ret==0){

			return 0 if($params[1]->{'whisker'}->{'code'} == 200);

			return 1 if($params[1]->{'whisker'}->{'code'} != 401);

			$params[0]->{'whisker'}->{'ntlm_step'}=1;

			my $thead=utils_find_lowercase_key($params[1],'www-authenticate');

			return 1 if(!defined $thead);

			return 1 if($thead!~m/^NTLM (.+)$/);  

			$params[0]->{'Authorization'}='NTLM '.ntlm_client(

				$params[0]->{'whisker'}->{'ntlm_obj'},$1);

		}

	}

	if($ret==0){

		delete $params[0]->{'Authorization'}

			if($params[0]->{'whisker'}->{'ntlm_step'}>1);

		$ret=LW::http_do_request_ex($params[0],$params[1]);

		$params[0]->{'Authorization'}=$auth; 

		if($ret>0){ 	$params[0]->{'whisker'}->{'ntlm_step'}=0;

		} else {	$params[0]->{'whisker'}->{'ntlm_step'}=2; }

		return $ret if($ret==2||$ret==0);

	}

    } else {

    	$ret=LW::http_do_request_ex($params[0],$params[1]);

	push @{${$params[1]}{'whisker'}->{'retry_errors'}},

		@retry_errors if scalar(@retry_errors);

	return $ret if($ret==0 || $ret==2);

    }

    push @retry_errors, ${$params[1]}{'whisker'}->{'error'};

    $retry_count--;

  } while( $retry_count >= 0);



 # if we get here, we still had errors, but no more retries

 return 1;

}



##################################################################



=pod



=head1 - Function: LW::http_do_request_ex

   

Params: \%req, \%resp, \%configs

Return: >=1 if error; 0 if no error



NOTE: you should go through http_do_request(), which calls this function.



This function actually does all the request work.  It is called by

http_do_request(), which has a 'retry wrapper' built into it to catch

errors.



=cut



sub http_do_request_ex {

 my ($hin, $hout, $hashref)=@_;

 my ($temp,$vin,$resp,$S,$a,$b,$vout,@c,$c,$res)=(1,'');

 my $W; # shorthand alias for the {'whisker'} hash



 return 1 if(!(defined $hin  && ref($hin) ));

 return 1 if(!(defined $hout && ref($hout)));



 %$hout=(); # clear output hash

 $$hout{whisker}->{uri}=$$hin{whisker}->{uri}; # for tracking purposes

 $$hout{whisker}->{'INITIAL_MAGIC'}=31338; # we can tell requests from responses



 if($LW::LW_HAS_SOCKET==0){

	$$hout{'whisker'}->{'error'}='Socket support not available';

	return 2;}



 if(!defined $$hin{'whisker'} || 

    !defined $$hin{'whisker'}->{'INITIAL_MAGIC'} ||

    $$hin{'whisker'}->{'INITIAL_MAGIC'}!=31337 ){

	$$hout{'whisker'}->{'error'}='Input hash not initialized';

	return 2;

 }



 if(defined $hashref){

	foreach (keys %$hashref){

		$$hin{'whisker'}->{$_}=$$hashref{$_};}}



 # if we want anti-IDS, make a copy and setup new values

 if(defined $$hin{'whisker'}->{'anti_ids'}){

	my %copy=%{$hin};

	anti_ids(\%copy,$$hin{'whisker'}->{'anti_ids'});

	$W = $copy{'whisker'};

 } else {

	$W = $$hin{'whisker'};

 }



 if($$W{'ssl'}>0 && $LW::LW_HAS_SSL!=1){

	$$hout{'whisker'}->{'error'}='SSL not available';

	return 2;}



 $TIMEOUT=$$W{'timeout'}||10;



 my $cache_key = defined $$W{'proxy_host'} ?

	join(':',$$W{'proxy_host'},$$W{'proxy_port'}) :

	join(':',$$W{'host'},$$W{'port'});



 if(!defined $http_host_cache{$cache_key}){

	# make new entry

	push(@{$http_host_cache{$cache_key}},

		undef, 	# SOC