#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<multipart_set>

Params: \%multi_hash, $param_name, $param_value

Return: nothing

This function sets the named parameter to the given value within the
supplied multipart hash.

=cut

sub multipart_set {
    my ( $hr, $n, $v ) = @_;
    return if ( !ref($hr) );    # error check
    return undef if ( !defined $n || $n eq '' );
    $$hr{$n} = $v;
}

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

=item B<multipart_get>

Params: \%multi_hash, $param_name

Return: $param_value, undef on error

This function retrieves the named parameter to the given value within the
supplied multipart hash.  There is a special case where the named
parameter is actually a file--in which case the resulting value will be
"\0FILE".  In general, all special values will be prefixed with a NULL
character.  In order to get a file's info, use multipart_getfile().

=cut

sub multipart_get {
    my ( $hr, $n ) = @_;
    return undef if ( !ref($hr) );                 # error check
    return undef if ( !defined $n || $n eq '' );
    return $$hr{$n};
}

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

=item B<multipart_setfile>

Params: \%multi_hash, $param_name, $file_path [, $filename]

Return: undef on error, 1 on success

NOTE: this function does not actually add the contents of $file_path into
the %multi_hash; instead, multipart_write() inserts the content when
generating the final request.

=cut

sub multipart_setfile {
    my ( $hr, $n, $path ) = ( shift, shift, shift );
    my ($fname) = shift;

    return undef if ( !ref($hr) );                 # error check
    return undef if ( !defined $n || $n eq '' );
    return undef if ( !defined $path );
    return undef if ( !( -e $path && -f $path ) );

    if ( !defined $fname ) {
        $path =~ m/[\\\/]([^\\\/]+)$/;
        $fname = $1 || "whisker-file";
    }

    $$hr{$n} = "\0FILE";
    $$hr{"\0$n"} = [ $path, $fname ];
    return 1;
}

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

=item B<multipart_getfile>

Params: \%multi_hash, $file_param_name

Return: $path, $name ($path=undef on error)

multipart_getfile is used to retrieve information for a file
parameter contained in %multi_hash.  To use this you would most
likely do:

 ($path,$fname)=LW2::multipart_getfile(\%multi,"param_name");

=cut

sub multipart_getfile {
    my ( $hr, $n ) = @_;

    return undef if ( !ref($hr) );                                 # error check
    return undef if ( !defined $n || $n eq '' );
    return undef if ( !defined $$hr{$n} || $$hr{$n} ne "\0FILE" );

    return @{ $$hr{"\0$n"} };
}

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

=item B<multipart_boundary>

Params: \%multi_hash [, $new_boundary_name]

Return: $current_boundary_name

multipart_boundary is used to retrieve, and optionally set, the
multipart boundary used for the request.

NOTE: the function does no checking on the supplied boundary, so if 
you want things to work make sure it's a legit boundary.  Libwhisker
does *not* prefix it with any '---' characters.

=cut

sub multipart_boundary {
    my ( $hr, $new ) = @_;
    my $ret;

    return undef if ( !ref($hr) );    # error check

    if ( !defined $$hr{"\0BOUNDARY"} ) {

        # create boundary on the fly
        my $b  = uc( utils_randstr(20) );
        my $b2 = '-' x 32;
        $$hr{"\0BOUNDARY"} = "$b2$b";
    }

    $ret = $$hr{"\0BOUNDARY"};
    if ( defined $new ) {
        $$hr{"\0BOUNDARY"} = $new;
    }

    return $ret;
}

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

=item B<multipart_write>

Params: \%multi_hash, \%request

Return: 1 if successful, undef on error

multipart_write is used to parse and construct the multipart data
contained in %multi_hash, and place it ready to go in the given whisker
hash (%request) structure, to be sent to the server.

NOTE: file contents are read into the final %request, so it's possible for
the hash to get *very* large if you have (a) large file(s).

=cut

sub multipart_write {
    my ( $mp, $hr ) = @_;

    return undef if ( !ref($mp) );    # error check
    return undef if ( !ref($hr) );    # error check

    if ( !defined $$mp{"\0BOUNDARY"} ) {

        # create boundary on the fly
        my $b  = uc( utils_randstr(20) );
        my $b2 = '-' x 32;
        $$mp{"\0BOUNDARY"} = "$b2$b";
    }

    my $B   = $$mp{"\0BOUNDARY"};
    my $EOL = $$hr{whisker}->{http_eol} || "\x0d\x0a";

    my $keycount = 0;
    foreach ( keys %$mp ) {
        next if ( substr( $_, 0, 1 ) eq "\0" );
        $keycount++;
        if ( $$mp{$_} eq "\0FILE" ) {
            my ( $path, $name ) = multipart_getfile( $mp, $_ );
            next if ( !defined $path );
            $$hr{whisker}->{data} .= "$B$EOL";
            $$hr{whisker}->{data} .=
              "Content-Disposition: " . "form-data; name=\"$_\"; ";
            $$hr{whisker}->{data} .= "filename=\"$name\"$EOL";
            $$hr{whisker}->{data} .=
              "Content-Type: " . "application/octet-stream$EOL";
            $$hr{whisker}->{data} .= $EOL;
            next if ( !open( IN, "<$path" ) );
            binmode(IN);    # stupid Windows

            while (<IN>) {
                $$hr{whisker}->{data} .= $_;
            }
            close(IN);
            $$hr{whisker}->{data} .= $EOL;    # WARNING: is this right?
        }
        else {
            $$hr{whisker}->{data} .= "$B$EOL";
            $$hr{whisker}->{data} .=
              "Content-Disposition: " . "form-data; name=\"$_\"$EOL";
            $$hr{whisker}->{data} .= "$EOL$$mp{$_}$EOL";
        }
    }

    if ($keycount) {
        $$hr{whisker}->{data} .= "$B--$EOL";    # closing boundary
        $$hr{"Content-Length"} = length( $$hr{whisker}->{data} );
        $$hr{"Content-Type"}   = "multipart/form-data; boundary=$B";
        return 1;
    }
    else {

        # multipart hash didn't contain params to upload
        return undef;
    }
}

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

=item B<multipart_read>

Params: \%multi_hash, \%hout_response [, $filepath ]

Return: 1 if successful, undef on error

multipart_read will parse the data contents of the supplied
%hout_response hash, by passing the appropriate info to
multipart_read_data().  Please see multipart_read_data() for more
info on parameters and behaviour.

NOTE: this function will return an error if the given %hout_response
Content-Type is not set to "multipart/form-data".

=cut

sub multipart_read {
    my ( $mp, $hr, $fp ) = @_;

    return undef if ( !( defined $mp && ref($mp) ) );
    return undef if ( !( defined $hr && ref($hr) ) );

    my $ctype = utils_find_lowercase_key( $hr, 'content-type' );
    return undef if ( !defined $ctype );
    return undef if ( $ctype !~ m#^multipart/form-data#i );

    return multipart_read_data( $mp, \$$hr{'whisker'}->{'data'}, undef, $fp );

}

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

=item B<multipart_read_data>

Params: \%multi_hash, \$data, $boundary [, $filepath ]

Return: 1 if successful, undef on error

multipart_read_data parses the contents of the supplied data using 
the given boundary and puts the values in the supplied %multi_hash.  
Embedded files will *not* be saved unless a $filepath is given, which
should be a directory suitable for writing out temporary files.

NOTE: currently only application/octet-stream is the only supported
file encoding.  All other file encodings will not be parsed/saved.

=cut

sub multipart_read_data {
    my ( $mp, $dr, $bound, $fp ) = @_;

    return undef if ( !( defined $mp && ref($mp) ) );
    return undef if ( !( defined $dr && ref($dr) ) );

    # if $bound is undef, then we'll snag what looks to be
    # the first boundry from the data.
    if ( !defined $bound ) {
        if ( $$dr =~ /([-]{5,}[A-Z0-9]+)[\r\n]/i ) {
            $bound = $1;
        }
        else {

            # we didn't spot a typical boundary; error
            return undef;
        }
    }

    if ( defined $fp && !( -d $fp && -w $fp ) ) {
        $fp = undef;
    }

    my $line = utils_getline_crlf( $dr, 0 );
    return undef if ( !defined $line );
    return undef if ( index( $line, $bound ) != 0 );

    my $done = 0;
    while ( !$done ) {
        $done = _multipart_read_data_part( $mp, $dr, $bound, $fp );
    }

    return 1;
}

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

sub _multipart_read_data_part {
    my ( $mp, $dr, $bound, $fp ) = @_;

    my $dispinfo = utils_getline_crlf($dr);
    return 1 if ( !defined $dispinfo );
    return 1 if ( length($dispinfo) == 0 );
    my $lcdisp = lc($dispinfo);

    if ( index( $lcdisp, 'content-disposition: form-data;' ) != 0 ) {
        return 1;
    }    # bad disposition

    my ( $s, $e, $l );

    $s = index( $lcdisp, 'name="', 30 );
    $e = index( $lcdisp, '"',      $s + 6 );
    return 1 if ( $s == -1 || $e == -1 );
    my $NAME = substr( $dispinfo, $s + 6, $e - $s - 6 );

    $s = index( $lcdisp, 'filename="', $e );
    my $FILENAME = undef;
    if ( $s != -1 ) {
        $e = index( $lcdisp, '"', $s + 10 );
        return 1 if ( $e == -1 );    # puke; malformed filename
        $FILENAME = substr( $dispinfo, $s + 10, $e - $s - 10 );
        $s        = rindex( $FILENAME, '\\' );
        $e        = rindex( $FILENAME, '/' );
        $s = $e if ( $e > $s );
        $FILENAME = substr( $FILENAME, $s + 1, length($FILENAME) - $s );
    }

    my $CTYPE = utils_getline_crlf($dr);

    return 1 if ( !defined $CTYPE );
    $CTYPE = lc($CTYPE);

    if ( length($CTYPE) > 0 ) {
        $s = index( $CTYPE, 'content-type:' );
        return 1 if ( $s != 0 );    # bad ctype line
        $CTYPE = substr( $CTYPE, 13, length($CTYPE) - 13 );
        $CTYPE =~ tr/ \t//d;
        my $xx = utils_getline_crlf($dr);
        return 1 if ( !defined $xx );
        return 1 if ( length($xx) > 0 );
    }
    else {
        $CTYPE = 'application/octet-stream';
    }

    my $VALUE = '';
    while ( defined( $l = utils_getline_crlf($dr) ) ) {
        last if ( index( $l, $bound ) == 0 );
        $VALUE .= $l;
        $VALUE .= "\r\n";
    }

    substr( $VALUE, -2, 2 ) = '';

    if ( !defined $FILENAME ) {    # read in param
        $$mp{$NAME} = $VALUE;
        return 0;

    }
    else {                         # read in file
        $$mp{$NAME} = "\0FILE";
        return 0 if ( !defined $fp );

        # TODO: funky content types, like application/x-macbinary
        if ( $CTYPE ne 'application/octet-stream' ) {
            return 0;
        }

        my $rfn      = lc( utils_randstr(12) );
        my $fullpath = "$fp$rfn";

        $$mp{"\0$NAME"} = [ undef, $FILENAME ];
        return 0 if ( !open( OUT, ">$fullpath" ) );    # error opening file
        binmode(OUT);                                  # stupid Windows
        $$mp{"\0$NAME"} = [ $fullpath, $FILENAME ];
        print OUT $VALUE;
        close(OUT);

        return 0;

    }    # if !defined $FILENAME

    return 0;    # um, this should never be reached...
}

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

=item B<multipart_files_list>

Params: \%multi_hash

Return: @files

multipart_files_list returns an array of parameter names for all
the files that are contained in %multi_hash.

=cut

sub multipart_files_list {
    my ($mp) = shift;
    my @ret;

    return () if ( !( defined $mp && ref($mp) ) );
    while ( my ( $K, $V ) = each(%$mp) ) {
        push( @ret, $K ) if ( $V eq "\0FILE" );
    }
    return @ret;
}

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

=item B<multipart_params_list>

Params: \%multi_hash

Return: @params

multipart_files_list returns an array of parameter names for all
the regular parameters (non-file) that are contained in %multi_hash.

=cut

sub multipart_params_list {
    my ($mp) = shift;
    my @ret;

    return () if ( !( defined $mp && ref($mp) ) );
    while ( my ( $K, $V ) = each(%$mp) ) {
        push( @ret, $K ) if ( $V ne "\0FILE"
            && substr( $K, 0, 1 ) ne "\0" );
    }
    return @ret;
}

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