lw2.pm

Ubuntu packages of security software。 相当不错的源码

Params: $data

Return: $result

This function randomly encodes characters (except the / character) with 
normal URL hex encoding.

=cut

sub encode_uri_randomhex {    # random normal hex encoding
    my @T = split( //, shift );
    my $s;
    foreach (@T) {
        if (m#[;=:&@\?]#) {
            $s .= $_;
            next;
        }
        if ( ( rand() * 2 ) % 2 == 1 ) { $s .= sprintf( "%%%02x", ord($_) ); }
        else { $s .= $_; }
    }
    return $s;
}

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

=item B<encode_uri_randomcase>

Params: $data

Return: $result

This function randomly changes the case of characters in the string.

=cut

sub encode_uri_randomcase {
    my ( $x, $uri ) = ( '', shift );
    return $uri if ( $uri !~ tr/a-zA-Z// );    # fast-path
    my @T = split( //, $uri );
    for ( $x = 0 ; $x < ( scalar @T ) ; $x++ ) {
        if ( ( rand() * 2 ) % 2 == 1 ) {
            $T[$x] =~ tr/A-Za-z/a-zA-Z/;
        }
    }
    return join( '', @T );
}

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

=item B<encode_unicode>

Params: $data

Return: $result

This function converts a normal string into Windows unicode format
(non-overlong or anything fancy).

=cut

sub encode_unicode {
    my ( $c, $r ) = ( '', '' );
    foreach $c ( split( //, shift ) ) {
        $r .= pack( "v", ord($c) );
    }
    return $r;
}

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

=item B<decode_unicode>

Params: $unicode_string

Return: $decoded_string

This function attempts to decode a unicode (UTF-8) string by
converting it into a single-byte-character string.  Overlong 
characters are converted to their standard characters in place; 
non-overlong (aka multi-byte) characters are substituted with the 
0xff; invalid encoding characters are left as-is.

Note: this function is useful for dealing with the various unicode
exploits/vulnerabilities found in web servers; it is *not* good for
doing actual UTF-8 parsing, since characters over a single byte are
basically dropped/replaced with a placeholder.

=cut

sub decode_unicode {
    my $str = $_[0];
    return $str if ( $str !~ tr/!-~//c );    # fastpath
    my ( $lead, $count, $idx );
    my $out = '';
    my $len = length($str);
    my ( $ptr, $no, $nu ) = ( 0, 0, 0 );

    while ( $ptr < $len ) {
        my $c = substr( $str, $ptr, 1 );
        if ( ord($c) >= 0xc0 && ord($c) <= 0xfd ) {
            $count = 0;
            $c     = ord($c) << 1;
            while ( ( $c & 0x80 ) == 0x80 ) {
                $c <<= 1;
                last if ( $count++ == 4 );
            }
            $c = ( $c & 0xff );
            for ( $idx = 1 ; $idx < $count ; $idx++ ) {
                my $o = ord( substr( $str, $ptr + $idx, 1 ) );
                $no = 1 if ( $o != 0x80 );
                $nu = 1 if ( $o < 0x80 || $o > 0xbf );
            }
            my $o = ord( substr( $str, $ptr + $idx, 1 ) );
            $nu = 1 if ( $o < 0x80 || $o > 0xbf );
            if ($nu) {
                $out .= substr( $str, $ptr++, 1 );
            }
            else {
                if ($no) {
                    $out .= "\xff";    # generic replacement char
                }
                else {
                    my $prior =
                      ord( substr( $str, $ptr + $count - 1, 1 ) ) << 6;
                    $out .= pack( "C",
                        (( ord( substr( $str, $ptr + $count, 1 ) ) & 0x7f ) +
                          $prior ) & 255 );
                }
                $ptr += $count + 1;
            }
            $no = $nu = 0;
        }
        else {
            $out .= $c;
            $ptr++;
        }
    }
    return $out;
}

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

=item B<encode_anti_ids>

Params: \%request, $modes

Return: nothing

encode_anti_ids computes the proper anti-ids encoding/tricks 
specified by $modes, and sets up %hin in order to use those tricks.  
Valid modes are (the mode numbers are the same as those found in whisker 
1.4):

=over 4

=item 1 Encode some of the characters via normal URL encoding

=item 2 Insert directory self-references (/./)

=item 3 Premature URL ending (make it appear the request line is done)

=item 4 Prepend a long random string in the form of "/string/../URL"

=item 5 Add a fake URL parameter

=item 6 Use a tab instead of a space as a request spacer

=item 7 Change the case of the URL (works against Windows and Novell)

=item 8 Change normal seperators ('/') to Windows version ('\')

=item 9 Session splicing [NOTE: not currently available]

=back

You can set multiple modes by setting the string to contain all the modes
desired; i.e. $modes="146" will use modes 1, 4, and 6.

=cut

sub encode_anti_ids {
    my ( $rhin, $modes ) = ( shift, shift );
    my ( @T, $x, $c, $s, $y );
    my $ENCODED = 0;
    my $W       = $$rhin{'whisker'};

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

    # in case they didn't do it already
    $$rhin{'whisker'}->{'uri_orig'} = $$rhin{'whisker'}->{'uri'};

    # note: order is important!

    # mode 9 - session splicing
    #if($modes=~/9/){
    #	$$rhin{'whisker'}->{'ids_session_splice'}=1;
    #}

    # mode 4 - prepend long random string
    if ( $modes =~ /4/ ) {
        $s = '';
        if ( $$W{'uri'} =~ m#^/# ) {
            $y = &utils_randstr;
            $s .= $y while ( length($s) < 512 );
            $$W{'uri'} = "/$s/.." . $$W{'uri'};
        }
    }

    # mode 7  - (windows) random case sensitivity
    if ( $modes =~ /7/ ) {
        $$W{'uri'} = encode_uri_randomcase( $$W{'uri'} );
    }

    # mode 2 - directory self-reference (/./)
    if ( $modes =~ /2/ ) {
        $$W{'uri'} =~ s#/#/./#g;
    }

    # mode 8 - windows directory separator (\)
    if ( $modes =~ /8/ ) {
        $$W{'uri'} =~ s#/#\\#g;
        $$W{'uri'} =~ s#^\\#/#;
        $$W{'uri'} =~ s#^([a-zA-Z0-9_]+):\\#$1://#;
        $$W{'uri'} =~ s#\\$#/#;
    }

    # mode 1 - random URI (non-UTF8) encoding
    if ( $modes =~ /1/ ) {
        if ( $ENCODED == 0 ) {
            $$W{'uri'} = encode_uri_randomhex( $$W{'uri'} );
            $ENCODED = 1;
        }
    }

    # mode 5 - fake parameter
    if ( $modes =~ /5/ ) {
        ( $s, $y ) = ( &utils_randstr, &utils_randstr );
        $$W{'uri'} = "/$s.html%3F$y=/../$$W{'uri'}";
    }

    # mode 3 - premature URL ending
    if ( $modes =~ /3/ ) {
        $s = &utils_randstr;
        $$W{'uri'} = "/%20HTTP/1.1%0d%0aAccept%3a%20$s/../..$$W{'uri'}";
    }

    # mode 6 - TAB as request spacer
    if ( $modes =~ /6/ ) {
        $$W{'http_space1'} = "\t";
    }

}


=item B<FORMS FUNCTIONS>

The goal is to parse the variable, human-readable HTML into concrete
structures useable by your program.  The forms functions does do a good job
at making these structures, but I will admit: they are not exactly simple,
and thus not a cinch to work with.  But then again, representing something
as complex as a HTML form is not a simple thing either.  I think the
results are acceptable for what's trying to be done.  Anyways...

Forms are stored in perl hashes, with elements in the following format:

 $form{'element_name'}=@([ 'type', 'value', @params ])

Thus every element in the hash is an array of anonymous arrays.  The first
array value contains the element type (which is 'select', 'textarea',
'button', or an 'input' value of the form 'input-text', 'input-hidden',
'input-radio', etc).

The second value is the value, if applicable (it could be undef if no
value was specified).  Note that select elements will always have an undef
value--the actual values are in the subsequent options elements.

The third value, if defined, is an anonymous array of additional tag
parameters found in the element (like 'onchange="blah"', 'size="20"',
'maxlength="40"', 'selected', etc).

The array does contain one special element, which is stored in the hash
under a NULL character ("\0") key.  This element is of the format:

 $form{"\0"}=['name', 'method', 'action', @parameters];

The element is an anonymous array that contains strings of the form's
name, method, and action (values can be undef), and a @parameters array
similar to that found in normal elements (above).

Accessing individual values stored in the form hash becomes a test of your
perl referencing skills.  Hint: to access the 'value' of the third element
named 'choices', you would need to do:

 $form{'choices'}->[2]->[1];

The '[2]' is the third element (normal array starts with 0), and the
actual value is '[1]' (the type is '[0]', and the parameter array is
'[2]').

=cut

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

# Cluster global variables
%_forms_ELEMENTS = (
    'form'     => 1,
    'input'    => 1,
    'textarea' => 1,
    'button'   => 1,
    'select'   => 1,
    'option'   => 1,
    '/select'  => 1
);

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

=item B<forms_read>

Params: \$html_data

Return: \@found_forms

This function parses the given $html_data into libwhisker form hashes.  
It returns a reference to an array of hash references to the found 
forms.

=cut

sub forms_read {
    my $dr = shift;
    return undef if ( !ref($dr) || length($$dr) == 0 );

    my $A = [ {}, [] ];

    html_find_tags( $dr, \&_forms_parse_callback, 0, $A, \%_forms_ELEMENTS );

    if ( scalar %{ $A->[0] } ) {
        push( @{ $A->[1] }, $A->[0] );
    }

    return $A->[1];
}

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

=item B<forms_write>

Params: \%form_hash

Return: $html_of_form [undef on error]

This function will take the given %form hash and compose a generic HTML
representation of it, formatted with tabs and newlines in order to make it
neat and tidy for printing.

Note: this function does *not* escape any special characters that were
embedded in the element values.

=cut

sub forms_write {
    my $hr = shift;
    return undef if ( !ref($hr) || !( scalar %$hr ) );
    return undef if ( !defined $$hr{"\0"} );

    my $t = '<form name="' . $$hr{"\0"}->[0] . '" method="';
    $t .= $$hr{"\0"}->[1] . '" action="' . $$hr{"\0"}->[2] . '"';
    if ( defined $$hr{"\0"}->[3] ) {
        $t .= ' ' . join( ' ', @{ $$hr{"\0"}->[3] } );
    }
    $t .= ">\n";

    my ( $name, $ar );
    while ( ( $name, $ar ) = each(%$hr) ) {
        next if ( $name eq "\0" );
        next if ( $name eq '' && $ar->[0]->[0] eq '' );
        foreach $a (@$ar) {
            my $P = '';
            $P = ' ' . join( ' ', @{ $$a[2] } ) if ( defined $$a[2] );
            $t .= "\t";

            if ( $$a[0] eq 'textarea' ) {
                $t .= "<textarea name=\"$name\"$P>$$a[1]";
                $t .= "</textarea>\n";

            }
            elsif ( $$a[0] =~ m/^input-(.+)$/ ) {
                $t .= "<input type=\"$1\" name=\"$name\" ";
                $t .= "value=\"$$a[1]\"$P>\n";

            }
            elsif ( $$a[0] eq 'option' ) {
                $t .= "\t<option value=\"$$a[1]\"$P>$$a[1]\n";

            }
            elsif ( $$a[0] eq 'select' ) {
                $t .= "<select name=\"$name\"$P>\n";

            }
            elsif ( $$a[0] eq '/select' ) {
                $t .= "</select$P>\n";

            }
            else {    # button
                $t .= "<button name=\"$name\" value=\"$$a[1]\">\n";
            }
        }
    }

    $t .= "</form>\n";
    return $t;
}

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

{    # these are 'private' static variables for &_forms_parse_html
    my $CURRENT_SELECT = undef;
    my $UNKNOWNS       = 0;

    sub _forms_parse_callback {
        my ( $TAG, $hr, $dr, $start, $len, $ar ) = ( lc(shift), @_ );
        my ( $saveparam, $parr, $key ) = ( 0, undef, '' );

        my $_forms_CURRENT = $ar->[0];
        my $_forms_FOUND   = $ar->[1];