#!/usr/bin/perl
#
# Copyright (c) 2001 Barclay D. Osborn
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#

package SaferCGI;

use strict;
require Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);

$VERSION   = '0.01';
@ISA       = qw(Exporter CGI);
@EXPORT    = qw();
@EXPORT_OK = qw();

use CGI;
use Carp;

sub new {
   my $referent = shift @_;
   my $class = ref($referent) || $referent;

   my $self = SUPER::new CGI(@_);
   bless($self,$class);
   return $self;
}

sub upload {
   my($self,$param_name) = CGI::self_or_default(@_);
   my $param = $self->SUPER::param($param_name);
   return unless $param;
   return unless ref($param) && fileno($param);
   return $param;
}

sub param(\$$;\@$) {
   my ($self,$param,$allow,$default) = @_;
   my $call = 0;

   if( ref($allow) eq 'CODE' ) {
      $call = 1;
   } else {
      $allow = "[^".$allow."]" if( $allow && $allow ne '' );
   }

   if( !$param ) {
      return $self->SUPER::param;
   }

   if( wantarray ) {
      my @data = $self->SUPER::param($param);

      if( $allow ) {
         for( my $i=0; $i<scalar(@data); $i++ ) {
            if( $call ) {
               $data[$i] = &$allow($data[$i]);
            } else {
               $data[$i] =~ s/$allow//g;
            } 
   
            if( !$data[$i] && $default )
               { $data[$i] = $default }
         }
      }
      return @data;
   } else {
      my $data = $self->SUPER::param($param);
      if( $call ) {
         $data = &$allow($data);
      } else {
         $data =~ s/$allow//g;
      } 
 
      if( !$data && $default ) { 
         return $default;
      }

      return $data;
   }
}

# This is totally bogus and wrong:
sub scrub_filename(\$$;) {
   my ($self,$path) = @_;
   $path =~ s/^.*\///;              # strip path
   $path =~ s/\.[^\w\-\_]*\.[^\w\-\_]*\///g;    # attempt to squash upward traversals
   $path = $self->scrub($path);  # And scrub the rest
   return $path;
}

sub scrub(\$$;) {
   my ($self,$data) = @_;

   $data =~ s/[\x00-\x08\x0c-\x1f\x7f-\xff]//g;
   $data =~ s/([\&;\`'\\\|"*?~<>^\(\)\[\]\{\}\$\n\r])/\\$1/g;

   return $data;
}

sub dirty(\$;) {
   my ($data) = shift(@_);
   $data =~ s/\\([\x00-\x08\x0c-\x1f\x7f-\xff\&;\`'\\\|"*?~<>^\(\)\[\]\{\}\$\n\r])/$1/g;
   return $data;
}

1;

__END__

=head1 NAME

SaferCGI - Small wrapper for CGI object that attempts to encourage safe CGI variable usage.

=head1 SYNOPSIS


   #/usr/bin/perl -I/place/where/SaferCGI/Resides
   # (or use lib qw(path/to/SaferCGI/directory/) );
   
   use SaferCGI;
   my $query = new SaferCGI;

   my $data1 = $query->param('field1', '\w\d');
   my $data2 = $query->param('field2', 'a-fA-F', 'Default Data');
   my $data3 = $query->param('field3', \&verification_func );
   my $data4 = $query->param('field4', \&verification_func, 'Default Data');
   my @all_field_names = $query->param;

   my $filename = $query->param('name');
   $filename = $query->scrub_filename($filename);
     (or)
   $filename = $query->scrub_filename( $query->param('name') );

   my $some_data = $query->scrub( $query->param('some_field') );
   my $almost_original_data = $query->dirty( $some_data );

=head1 CAVEAT

   Note the safest method is to use allowable characters or a verification 
   function in the param() call, and then any scrub() functions later as
   necessary, as the allowable characters method defaults to discarding
   data, while the scrub functions default to passing data (although
   their deny data sets should be reasonably good.)

=head1 DESCRIPTION


   Pretty Basic Really:

   param( $field, $allowables, $default );
      Wraps CGI::param.  $field contains the field to snag the
      paramter data from.  Prior to return, any data not listed
      in $allowables is removed, i.e.,g s/[^$allowables]//g.  If
      $default is present, and the data ends up empty because
      of either the field had no value or all the data was removed,
      then it is assigned the value contained in $default - the data
      in the $default string is *NOT* scrubbed.  If $allowables is not 
      present, no scrubbing is done.  Defaults can be set on parameters 
      without scrubbing by specifying a null ('') allowable string.

      If $allowables is a reference to a function, then that function
      will be called to scrub the data - the function should take
      a scalar as an argument, and return a scalar.
 
      If returns the first item for a field if resultant is a scalar,
      otherwise a list of all items for the field if resultant is a
      list, subject to the above constraints.

      If you want to bypass all SaferCGI mechanism, and just use the
      straight CGI functionality, just call:
         $query->SUPER::param(...)
 
   scrub( $data );
      Remove the following (ASCII) charaters from $data:
         Hex  0 through  8 (0x00-0x08)
         Hex  c through 1f (0x0c-0x1f)
         Hex 7f through ff (0xff-0xff)
      Then escapes the following characters from $data (precedes the
      character with a '\'):
         & ; ` ' \ | " * ? ~ < > ^ ( ) [ ] { } $ \n \r
      Returns a copy of the data modified as above.

   scrub_filename( $filename );
      Removes the path portion of the filename (everything up to and including
      the last '/').
      Attempts to remove any upward directory traversals by removing them (e.g,
      ../, .{./.}., .\./, etc.)
      Finally, calls scrub() on the resultant data and returns it.

   dirty( $data );
      Almost the opposide of scrub - it removes the escapes from data with
      escaped characters.  Isn't exactly the opposite of scrub, as it cannot
      replace charaters (mainly high-bit ASCII) that scrub removed.

=head1 CREDITS

   Barclay Osborn (bosborn@cyberpass.net)
   Props to me.  Whee.

=cut