/usr/share/perl5/Class/DBI/FromCGI.pm is in libclass-dbi-fromcgi-perl 1.00-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | package Class::DBI::FromCGI;
$VERSION = '1.00';
use strict;
use Exporter;
use vars qw/@ISA @EXPORT/;
use base 'Exporter';
@EXPORT = qw/update_from_cgi create_from_cgi untaint_columns
cgi_update_errors untaint_type/;
sub untaint_columns {
die "untaint_columns() needs a hash" unless @_ % 2;
my ($class, %args) = @_;
$class->mk_classdata('__untaint_types')
unless $class->can('__untaint_types');
my %types = %{ $class->__untaint_types || {} };
while (my ($type, $ref) = each(%args)) {
$types{$type} = $ref;
}
$class->__untaint_types(\%types);
}
sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }
sub update_from_cgi {
my $self = shift;
die "update_from_cgi cannot be called as a class method" unless ref $self;
__PACKAGE__->_run_update($self, @_);
}
sub create_from_cgi {
my $class = shift;
die "create_from_cgi can only be called as a class method" if ref $class;
__PACKAGE__->_run_create($class, @_);
}
sub untaint_type {
my ($class, $field) = @_;
my %handler = __PACKAGE__->_untaint_handlers($class);
return $handler{$field} if $handler{$field};
my $handler = eval {
local $SIG{__WARN__} = sub { };
my $type = $class->column_type($field) or die;
_column_type_for($type);
};
return $handler || undef;
}
#----------------------------------------------------------------------
sub _validate {
my ($me, $them, $h, $wanted, $extra_ignore) = @_;
my %wanted = $me->_parse_columns($them => @$wanted);
my %required = map { $_ => 1 } @{ $wanted{required} };
my %seen;
$seen{$_}++ foreach @$extra_ignore, @{ $wanted{ignore} };
$them->{_cgi_update_error} = {};
my $fields = {};
foreach my $field (@{ $wanted{required} }, @{ $wanted{all} }) {
next if $seen{$field}++;
my $type = $them->untaint_type($field) or next;
my $value = $h->extract("-as_$type" => $field);
my $err = $h->error;
if ($required{$field} and not $value) {
$them->{_cgi_update_error}->{$field} = "You must supply '$field'";
} elsif ($err) {
$them->{_cgi_update_error}->{$field} = $err
unless $err =~ /^No parameter for/;
} else {
$fields->{$field} = $value;
}
}
return ($them, $fields);
}
sub _run_update {
my ($me, $them, $h, @wanted) = @_;
my $class = ref($them);
my $to_update;
($them, $to_update) =
$me->_validate($them, $h, \@wanted, [ $them->primary_column ]);
return if $them->cgi_update_errors;
$them->set(%$to_update);
return 1;
}
sub _run_create {
my ($me, $class, $h, @wanted) = @_;
my $them = bless {}, $class;
my $to_update;
($them, $to_update) = $me->_validate($them, $h, \@wanted, []);
# TODO overload to false in boolean?
return $them if $them->cgi_update_errors;
return $class->create($to_update);
}
sub _parse_columns {
my ($me, $them, @cols) = @_;
my %cols;
if (ref($cols[0]) eq "HASH") {
my %hash = %{ $cols[0] };
@cols{ keys %hash } = values %hash;
} else {
$cols{all} = [@cols] if @cols;
}
$cols{all} = [ $them->columns('All') ] if not @{ $cols{all} || [] };
return %cols;
}
sub _untaint_handlers {
my ($me, $them) = @_;
return () unless $them->can('__untaint_types');
my %type = %{ $them->__untaint_types || {} };
my %h;
@h{ @{ $type{$_} } } = ($_) x @{ $type{$_} } foreach keys %type;
return %h;
}
sub _column_type_for {
my $type = lc shift;
$type =~ s/\(.*//;
my %map = (
varchar => 'printable',
char => 'printable',
text => 'printable',
tinyint => 'integer',
smallint => 'integer',
mediumint => 'integer',
int => 'integer',
bigint => 'integer',
year => 'integer',
date => 'date',
);
return $map{$type} || "";
}
1;
__END__
=head1 NAME
Class::DBI::FromCGI - Update Class::DBI data using CGI::Untaint
=head1 SYNOPSIS
package Film;
use Class::DBI::FromCGI;
use base 'Class::DBI';
# set up as any other Class::DBI class.
__PACKAGE__->untaint_columns(
printable => [qw/Title Director/],
integer => [qw/DomesticGross NumExplodingSheep/],
date => [qw/OpeningDate/],
);
# Later on, over in another package ...
my $h = CGI::Untaint->new( ... );
my $film = Film->retrieve('Godfather II');
$film->update_from_cgi($h);
my $new_film = Film->create_from_cgi($h);
if (my %errors = $film->cgi_update_errors) {
while (my ($field, $problem) = each %errors) {
warn "Problem with $field: $problem\n";
}
}
# or
$film->update_from_cgi($h => @columns_to_update);
# or
$film->update_from_cgi($h => { ignore => \@cols_to_ignore,
required => \@cols_needed,
all => \@columns_which_may_be_empty });
my $how = $film->untaint_type('Title'); # printable
=head1 DESCRIPTION
Lots of times, Class::DBI is used in web-based applications. (In fact,
coupled with a templating system that allows you to pass objects, such
as Template::Toolkit, Class::DBI is very much your friend for these.)
And, as we all know, one of the most irritating things about writing
web-based applications is the monotony of writing much of the same stuff
over and over again. And, where there's monotony there's a tendency to
skip over stuff that we all know is really important, but is a pain to
write - like Taint Checking and sensible input validation. (Especially
as we can still show a 'working' application without it!). So, we now
have CGI::Untaint to take care of a lot of that for us.
It so happens that CGI::Untaint also plays well with Class::DBI.
Class::DBI::FromCGI is a little wrapper that ties these two together.
=head1 METHODS
=head2 untaint_columns
All you need to do is to 'use Class::DBI::FromCGI' in your class (or
in your local Class::DBI subclass that all your other classes inherit
from. You do do that, don't you?).
Then, in each class in which you want to use this, you declare how you
want to untaint each column:
__PACKAGE__->untaint_columns(
printable => [qw/Title Director/],
integer => [qw/DomesticGross NumExplodingSheep/],
date => [qw/OpeningDate/],
);
(where the keys are the CGI::Untaint package to be used, and the values
a listref of the relevant columns).
=head2 update_from_cgi
When you want to update based on the values coming in from a
web-based form, you just call:
$obj->update_from_cgi($h => @columns_to_update);
If every value passed in gets through the CGI::Untaint process, the object
will be updated (but not committed, in case you want to do anything else
with it). Otherwise the update will fail (there are no partial updates),
and $obj->cgi_update_errors will tell you what went wrong (as a hash of
problem field => error from CGI::Untaint).
=head2 create_from_cgi
Similarly, if you wish to create a new object, then you can call:
my $obj = Class->create_from_cgi($h => @columns_to_update);
If this fails, $obj will be a defined object, containing the errors,
as with an update, but will not contain the values submitted, nor have
been written to the database.
=head2 untaint_type
my $how = $film->untaint_type('Title'); # printable
This tells you how we're going to untaint a given column.
=head2 cgi_update_errors
if (my %errors = $film->cgi_update_errors) {
while (my ($field, $problem) = each %errors) {
warn "Problem with $field: $problem\n";
}
}
This returns a hash of any errors when updating. Despite its name it
also applies when inserting.
=head1 Column Auto-Detection
As Class::DBI knows all its columns, you don't even have to say
what columns you're interested in, unless it's a subset, as we can
auto-fill these:
$obj->update_from_cgi($h);
You can also specify columns which must be present, or columns to be
ignored even if they are present:
$film->update_from_cgi($h => {
all => \@all_columns, # auto-filled if left blank
ignore => \@cols_to_ignore,
required => \@cols_needed,
});
Doesn't this all make your life so much easier?
=head1 NOTE
Don't try to update the value of your primary key. Class::DBI doesn't
like that. If you try to do this it will be silently skipped.
=head1 ANOTHER NOTE
If you haven't set up any 'untaint_column' information for a column which
you later attempt to untaint, then we try to call $self->column_type to
ascertain the default handler to use. Currently this will only use if
you're using Class::DBI::mysql, and only for certain column types.
=head1 SEE ALSO
L<Class::DBI>. L<CGI::Untaint>. L<Template>.
=head1 AUTHOR
Tony Bowden
=head1 BUGS and QUERIES
Please direct all correspondence regarding this module to:
bug-Class-DBI-FromCGI@rt.cpan.org
=head1 COPYRIGHT
Copyright (C) 2001-2005 Kasei. All rights reserved.
This module is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
|