Class::DBI::Plugin::AutoUntaint - untaint columns automatically

    package Film;
    use Class::DBI::FromCGI;
    use Class::DBI::Plugin::Type;
    use Class::DBI::Plugin::AutoUntaint;
    use base 'Class::DBI';
    # set up as any other Class::DBI class.

    # instead of this:
    #__PACKAGE__->untaint_columns(
    #    printable => [qw/Title Director/],
    #    integer   => [qw/DomesticGross NumExplodingSheep],
    #    date      => [qw/OpeningDate/],
    #    );

    # say this:
    __PACKAGE__->auto_untaint;

package Class::DBI::Plugin::AutoUntaint;
use Carp();

use warnings;
use strict;

our $VERSION = 0.1;

our %TypesMap = ( varchar   => 'printable',
                  char      => 'printable', # includes MySQL enum and set
                  blob      => 'printable', # includes MySQL text
                  text      => 'printable',
                  
                  integer   => 'integer',
                  bigint    => 'integer',
                  smallint  => 'integer',
                  tinyint   => 'integer',
                  int       => 'integer',
                  
                  # loads Date::Manip, which is powerful, but big and slow
                  date      => 'date',
                  
                  # normally you want to skip untainting a timestamp column...
                  #timestamp => 'date',
                  
                  # someone should write CGI::Untaint::number
                  double    => 'printable',
                  float     => 'printable',
                  decimal   => 'printable',
                  );    

sub import
{
    my ( $class ) = @_;
    
    my $caller = caller;
    
    no strict 'refs';   
    *{"$caller\::auto_untaint"} = \&auto_untaint;
}

sub auto_untaint 
{   # plugged-into class i.e. CDBI class
    my ( $class, %args ) = @_;
    
    warn "Untainting $class\n" if $args{debug} == 1;
    
    my $untaint_cols = $args{untaint_columns} || {}; 
    my $skip_cols    = $args{skip_columns}    || [];
    my $match_cols   = $args{match_columns}   || {}; 
    my $ut_types     = $args{untaint_types}   || {}; 
    my $match_types  = $args{match_types}     || {}; 
    
    my %skip = map { $_ => 1 } @$skip_cols;
    
    my %ut_cols;
    
    foreach my $as ( keys %$untaint_cols )
    {
        $ut_cols{ $_ } = $as for @{ $untaint_cols->{ $as } };
    }
    
    my %untaint;
    
    # $col->name preserves case - stringifying doesn't
    foreach my $col ( map { $_->name } $class->columns )
    {
        next if $skip{ $col };    
        
        my $type = $class->column_type( $col );
        
        die "No type detected for column $col ($class)" unless $type;

        my $ut = $ut_cols{ $col } || $ut_types->{ $type } || $TypesMap{ $type } || '';
                 
        foreach my $regex ( keys %$match_types )
        {
            last if $ut;
            $ut = $match_types->{ $regex } if $type =~ $regex;
        }
        
        foreach my $regex ( keys %$match_cols )
        {
            last if $ut;
            $ut = $match_cols->{ $regex } if $col =~ $regex;
        }
        
        my $skip_ts = ( ( $type eq 'timestamp' ) && ! $ut );
        
        warn "Skipping   $class $col [timestamp]\n" 
            if ( $skip_ts and $args{debug} > 1 );
        
        next if $skip_ts;
        
        my $fail = "No untaint type detected for column $col, type $type in $class"
            unless $ut;
            
        $fail and $args{strict} ? die $fail : warn $fail;
    
        my $type2 = substr( $type, 0, 25 );
        $type2 .= '...' unless $type2 eq $type;
        
        warn sprintf "Untainting %s %s [%s] as %s\n", 
            $class, $col, $type2, $ut 
            if $args{debug} > 1;
        
        push( @{ $untaint{ $ut } }, $col ) if $ut;
    }
    
    $class->untaint_columns( %untaint );    
}

1; # End of Class::DBI::Plugin::AutoUntaint