#GPL
#GPL  libwhisker copyright 2000-2004 by rfp.labs
#GPL
#GPL  This program is free software; you can redistribute it and/or
#GPL  modify it under the terms of the GNU General Public License
#GPL  as published by the Free Software Foundation; either version 2
#GPL  of the License, or (at your option) any later version.
#GPL
#GPL  This program is distributed in the hope that it will be useful,
#GPL  but WITHOUT ANY WARRANTY; without even the implied warranty of
#GPL  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#GPL  GNU General Public License for more details.
#GPL

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

=item B<utils_recperm>

Params: $uri, $depth, \@dir_parts, \@valid, \&func, \%track, \%arrays, \&cfunc

Return: nothing

This is a special function which is used to recursively-permutate through
a given directory listing.  This is really only used by whisker, in order
to traverse down directories, testing them as it goes.  See whisker 2.0 for
exact usage examples.

=cut

# '/', 0, \@dir.split, \@valid, \&func, \%track, \%arrays, \&cfunc
sub utils_recperm {
 my ($d, $p, $pp, $pn, $r, $fr, $dr, $ar, $cr)=('',shift,shift,@_);
 $p=~s#/+#/#g; if($pp >= @$pn) { push @$r, $p if &$cr($$dr{$p});
 } else { my $c=$$pn[$pp];
  if($c!~/^\@/){ utils_recperm($p.$c.'/',$pp+1,@_) if(&$fr($p.$c.'/'));
  } else {	$c=~tr/\@//d; if(defined $$ar{$c}){
		foreach $d (@{$$ar{$c}}){
			if(&$fr($p.$d.'/')){
                  utils_recperm($p.$d.'/',$pp+1,@_);}}}}}}


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

=item B<utils_array_shuffle>

Params: @array

Return: nothing

This function will randomize the order of the elements in the given array.

=cut

sub utils_array_shuffle { # fisher yates shuffle....w00p!
        my $array=shift; my $i;
        for ($i = @$array; --$i;){
                my $j = int rand ($i+1);
                next if $i==$j;
                @$array[$i,$j]=@$array[$j,$i];
}} # end array_shuffle, from Perl Cookbook (rock!)


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

=item B<utils_randstr>

Params: [ $size, $chars ]

Return: $random_string

This function generates a random string between 10 and 20 characters
long, or of $size if specified.  If $chars is specified, then the
random function picks characters from the supplied string.  For example,
to have a random string of 10 characters, composed of only the characters
'abcdef', then you would run:

 utils_randstr(10,'abcdef');

The default character string is alphanumeric.

=cut

sub utils_randstr {
        my $str;
        my $drift=shift||((rand() * 10) % 10)+10; 

	# 'a'..'z' doesn't seem to work on string assignment :(
	my $CHARS = shift || 'abcdefghijklmnopqrstuvwxyz' .
			'ABCDEFGHIJKLMNOPQRSTUVWXYZ' .
			'0123456789';

	my $L = length($CHARS);
        for(1..$drift){
	        $str .= substr($CHARS,((rand() * $L) % $L),1);
	}
        return $str;}

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

=item B<utils_port_open>

Params: $host, $port

Return: $result

Quick function to attempt to make a connection to the given host and
port.  If a connection was successfully made, function will return true
(1).  Otherwise it returns false (0).

Note: this uses standard TCP connections, thus is not recommended for use
in port-scanning type applications.  Extremely slow.

=cut

sub utils_port_open {  # this should be platform-safe
        my ($target,$port)=@_;

	return 0 if(!defined $target || !defined $port);
	return 0 if(!defined $AVAILABLE{socket});

        if(!(socket(S,PF_INET,SOCK_STREAM,0))){ return 0;}
        if(connect(S,sockaddr_in($port,inet_aton($target)))){
                close(S); return 1;
        } else { return 0;}}

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

=item B<utils_lowercase_keys>

Params: \%hash

Return: $number_changed

Will lowercase all the header names (but not values) of the given hash.

=cut

sub utils_lowercase_keys {
	my $href=shift;

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

	my $count=0;
	while( my ($key,$val)=each %$href ){
		if($key=~tr/A-Z//c){
			$count++;
			delete $$href{$key};
			$$href{lc($key)}=$val; }
	}
	return $count;
}

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

=item B<utils_find_lowercase_key>

Params: \%hash, $key

Return: $value, undef on error or not exist

Searches the given hash for the $key (regardless of case), and
returns the value. If the return value is placed into an array, the
will dereference any multi-value references and return an array of
all values.

=cut

sub utils_find_lowercase_key {
	my ($href,$key)=(shift,lc(shift));

	return undef if(!(defined $href && ref($href)));
	return undef if(!defined $key);	

	while( my ($k,$v)=each %$href ){
		if(lc($k) eq $key){
			return @$v if(ref($v) && wantarray());
			return $v;
		}
	}
	return undef;
}

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

=item B<utils_getline>

Params: \$data [, $resetpos ]

Return: $line (undef if no more data)

Fetches the next \n terminated line from the given data.  Use
the optional $resetpos to reset the internal position pointer.
Does *NOT* return trialing \n.

=cut

{ $POS=0;
sub utils_getline {
	my ($dr, $rp)=@_;

	return undef if(!(defined $dr && ref($dr)));
	$POS=$rp if(defined $rp);

	my $where=index($$dr,"\n",$POS);
	return undef if($where==-1);

	my $str=substr($$dr,$POS,$where-$POS);
	$POS=$where+1;

	return $str;
}}

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

=item B<utils_getline_crlf>

Params: \$data [, $resetpos ]

Return: $line (undef if no more data)

Fetches the next \r\n terminated line from the given data.  Use
the optional $resetpos to reset the internal position pointer.
Does *NOT* return trialing \r\n.

=cut

{ $POS=0;
sub utils_getline_crlf {
	my ($dr, $rp)=@_;

	return undef if(!(defined $dr && ref($dr)));
	$POS=$rp if(defined $rp);

	my $tpos=$POS;
	while(1){
		my $where=index($$dr,"\n",$tpos);
		return undef if($where==-1);

		if(substr($$dr,$where-1,1) eq "\r"){
			my $str=substr($$dr,$POS,$where-$POS-1);
			$POS=$where+1;
			return $str;
		} else {
			$tpos=$where+1;
		}
	}
}}

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

=item B<utils_save_page>

Params: $file, \%response

Return: 0 on success, 1 on error

Saves the data portion of the given whisker %response hash to the
indicated file.  Can technically save the data portion of a
%request hash too.  A file is not written if there is no data.

Note: LW does not do any special file checking; files are opened
in overwrite mode.

=cut

sub utils_save_page {
	my ($file, $hr)=@_;
	return 1 if(!ref($hr) || ref($file));
	return 0 if(!defined $$hr{'whisker'} || 
		!defined $$hr{'whisker'}->{'data'});
	open(OUT,">$file") || return 1;
	print OUT $$hr{'whisker'}->{'data'};
	close(OUT);
	return 0;
}

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

=item B<utils_getopts>

Params: $opt_str, \%opt_results

Return: 0 on success, 1 on error

This function is a general implementation of GetOpts::Std.  It will
parse @ARGV, looking for the options specified in $opt_str, and will
put the results in %opt_results.  Behavior/parameter values are
similar to GetOpts::Std's getopts().

Note: this function does *not* support long options (--option),
option grouping (-opq), or options with immediate values (-ovalue).
If an option is indicated as having a value, it will take the next
argument regardless.

=cut

sub utils_getopts {
        my ($str,$ref)=@_;
        my (%O,$l);
        my @left;

        return 1 if($str=~tr/-:a-zA-Z0-9//c);

        while($str=~m/([a-z0-9]:{0,1})/ig){
                $l=$1;
                if($l=~tr/://d){        $O{$l}=1;
                } else {                $O{$l}=0; }
        }

        while($l=shift(@ARGV)){
                push(@left,$l)&&next if(substr($l,0,1) ne '-');
                push(@left,$l)&&next if($l eq '-');
                substr($l,0,1)='';
                if(length($l)!=1){
                        %$ref=();
                        return 1; }
                if($O{$l}==1){
                        my $x=shift(@ARGV);
                        $$ref{$l}=$x;
                } else { $$ref{$l}=1; }
        }

        @ARGV=@left;
        return 0;
}

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

=item B<utils_text_wrapper>

Params: $long_text_string [, $crlf, $width ]

Return: $formatted_test_string

This is a simple function used to format a long line of text for
display on a typical limited-character screen, such as a unix
shell console.

$crlf defaults to "\n", and $width defaults to 76.

=cut

sub utils_text_wrapper {
        my ($out,$w,$str,$crlf,$width)=('',0,@_);
	$crlf||="\n";	$width||=76;
        $str.=$crlf if($str!~/$crlf$/);
        return $str if(length($str)<=$width);
        while(length($str)>$width){
                my $w1=rindex($str,' ',$width);
                my $w2=rindex($str,"\t",$width);
                if($w1>$w2){ $w=$w1; } else { $w=$w2; }
                if($w==-1){	$w=$width;
	        } else {	substr($str,$w,1)=''; }
                $out.=substr($str,0,$w,'');
                $out.=$crlf;
        }
        return $out.$str;
}

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

=item B<utils_bruteurl>

Params: \%req, $pre, $post, \@values_in, \@values_out

Return: Nothing (adds to @out)
        
Bruteurl will perform a brute force against the host/server specified in
%req.  However, it will make one request per entry in @in, taking the
value and setting $hin{'whisker'}->{'uri'}= $pre.value.$post.  Any URI
responding with an HTTP 200 or 403 response is pushed into @out.  An
example of this would be to brute force usernames, putting a list of
common usernames in @in, setting $pre='/~' and $post='/'.

=cut
sub utils_bruteurl {
 my ($hin, $upre, $upost, $arin, $arout)=@_;
 my ($U,%hout);

 return if(!(defined $hin   && ref($hin)  ));
 return if(!(defined $arin  && ref($arin) ));
 return if(!(defined $arout && ref($arout)));
 return if(!defined $upre  || length($upre) ==0);
 return if(!defined $upost || length($upost)==0);

 http_fixup_request($hin);

 map {
  ($U=$_)=~tr/\r\n//d; next if($U eq '');
  if(!http_do_request($hin,\%hout,{'uri'=>$upre.$U.$upost})){
    if(	$hout{'whisker'}->{'code'}==200 ||
	$hout{'whisker'}->{'code'}==403){
	push(@{$arout},$U);
    }
  }
 } @$arin;
}

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

=item B<utils_join_tag>

Params: $tag_name, \%attributes

Return: $tag_string [undef on error]
        
This function takes the $tag_name (like 'A') and a hash full of
attributes (like {href=>'http://foo/'}) and returns the 
constructed HTML tag string (<A href="http://foo">).

=cut

sub utils_join_tag {
	my ($name, $href)=@_;
	return undef if(!defined $name || $name eq '');
	return undef if(!defined $href || !ref($href));
	my ($out,$k,$v)=("<$name",'','');
	while(($k,$v)=each %$href){
		next if($k eq '');
		$out.=" $k";
		$out.="=\"$v\"" if(defined $v);
	}
	$out.='>';
	return $out;
}

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

=item B<utils_request_clone>

Params: \%from_request, \%to_request

Return: 1 on success, 0 on error

This function takes the connection/request-specific values from the
given from_request hash, and copies them to the to_request hash.

=cut

sub utils_request_clone {
	my ($from, $to)=@_;
	return 0 if(!defined $from || !ref($from));
	return 0 if(!defined $to || !ref($to));
	return 0 if(!defined $from->{whisker}->{MAGIC});
	return 0 if(!defined $to->{whisker}->{MAGIC});

        my @C=qw(host port ssl proxy_host proxy_port file_stream
                        stream_num UDP bind_socket bind_port
                        bind_addr version include_host_in_uri
                        ntlm_step ntlm_obj);
        foreach (@C){
                if(exists $from->{whisker}->{$_}){
                        $to->{whisker}->{$_}=$from->{whisker}->{$_};
                } else {
                        delete $to->{whisker}->{$_};
                }
        }

        @C=qw(Connection Authorization User-Agent);
        foreach (@C){
                if(defined $from->{$_}){
                        $to->{$_}=$from->{$_};
                } else {
                        delete $to->{$_};
                }
        }
	return 1;
}

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

=item B<utils_request_fingerprint>

Params: \%request [, $hash ]

Return: $fingerprint [undef on error]
        
This function constructs a 'fingerprint' of the given request by
using a cryptographic hashing function on the constructed original
HTTP request.

Note: $hash can be 'md5' (default) or 'md4'.

=cut

sub utils_request_fingerprint {
	my ($href,$hash)=@_;
	$hash||='md5';
	return undef if(!defined $href || !ref($href));
	return undef if(!defined $href->{whisker}->{MAGIC});

	my $data='';
	if( $href->{whisker}->{MAGIC} == 31339 ){ # LW2 request
		$data = http_req2line($href);
 		if($href->{whisker}->{version} ne '0.9'){
			$data.=http_construct_headers($href);
			$data.=$href->{whisker}->{raw_header_data} 
				if(defined $href->{whisker}->{raw_header_data});
			$data.=$href->{whisker}->{http_eol};
			$data.=$href->{whisker}->{data} 
				if(defined $href->{whisker}->{data});
		} # http 0.9 support

		return 'md5:'.md5($data) if($hash eq 'md5');
		return 'md4:'.md4($data) if($hash eq 'md4');
	}

	return undef;
}

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