# $Id: Regexes.pm 2193 2007-03-15 06:41:50Z comdog $
package Brick::File;
use strict;
use base qw(Exporter);
use vars qw($VERSION);
$VERSION = sprintf "1.%04d", q$Revision: 2193 $ =~ m/ (\d+) /xg;
package Brick::Bucket;
use strict;
use Carp qw(croak);
=head1 NAME
Brick::File - This is the description
=head1 SYNOPSIS
see L<Brick>
=head1 DESCRIPTION
See C<Brick::Constraints> for the general discussion of constraint
creation.
=head2 Utilities
=over 4
=cut
# returns MIME type from File::MMagic on success, undef otherwise
sub _file_magic_type
{
my( $bucket, $file ) = @_;
require File::MMagic;
my $mm = File::MMagic->new;
my $format = $mm->checktype_filename( $file || '' );
## File::MMagic returns the illegal "application/msword" for all
## microsoft junk.
## We map this to either application/x-msword (default)
## or application/vnd.ms-excel, depending on the extension
my( $uploaded_ext ) = $file =~ m/\.(\w*)?$/g;
if( $format eq "application/msword" )
{
no warnings 'uninitialized';
$format = ($uploaded_ext =~ /^xl[st]$/)
?
"application/vnd.ms-excel"
:
"application/x-msword";
}
elsif( $format =~ m|x-system/x-error| )
{
$format = undef;
}
return $format;
}
sub _get_file_extensions_by_mime_type
{
my( $bucket, $type ) = @_;
require MIME::Types;
my $mime_types = MIME::Types->new;
my $t = $mime_types->type( $type || '' );
my @extensions = $t ? $t->extensions : ();
}
=item is_mime_type( HASH_REF )
Passes if the file matches one of the listed MIME types.
mime_types array reference of possible MIME types
file_field the name of the file to check
=cut
sub is_mime_type {
my( $bucket, $setup ) = @_;
my @caller = $bucket->__caller_chain_as_list;
unless( UNIVERSAL::isa( $setup->{mime_types}, ref [] ) )
{
croak( "The mime_types key must be an array reference!" );
}
my $hash = {
name => $setup->{name} || $caller[0]{'sub'},
description => ( $setup->{description} || "Match a file extension" ),
fields => [ $setup->{field} ],
code => sub {
my( $input ) = @_;
die {
message => "[$input->{ $setup->{file_field} }] did not exist.",
failed_field => $setup->{file_field},
failed_value => $input->{ $setup->{file_field} },
handler => $caller[0]{'sub'},
} unless -e $input->{ $setup->{file_field} };
my $mime_type = $bucket->_file_magic_type( $input->{ $setup->{file_field} } );
die {
message => "[$input->{ $setup->{file_field} }] did not yeild a mime type.",
failed_field => $setup->{file_field},
failed_value => $input->{ $setup->{file_field} },
handler => $caller[0]{'sub'},
} unless $mime_type;
foreach my $expected_type ( @{ $setup->{mime_types} } )
{
return 1 if lc $mime_type eq lc $expected_type;
}
die {
message => "[$input->{ $setup->{file_field} }] did not have the right mime type. I think it's $mime_type.",
failed_field => $setup->{filename},
failed_value => $input->{ $setup->{file_field} },
handler => $caller[0]{'sub'},
};
},
};
$bucket->__make_constraint(
$bucket->add_to_bucket ( $hash )
);
}
=item has_file_extension( HASH_REF )
This constraint checks the filename against a list of extensions
which are the elements of ARRAY_REF.
field the name of the field holding the filename
extensions an array reference of possible extensions
=cut
sub Brick::_get_file_extension # just a sub, not a method
{
lc +( split /\./, $_[0] )[-1];
}
sub has_file_extension
{
my( $bucket, $setup ) = @_;
my @caller = $bucket->__caller_chain_as_list;
unless( UNIVERSAL::isa( $setup->{extensions}, ref [] ) )
{
croak( "The extensions key must be an array reference!" );
}
my %extensions = map { lc $_, 1 } @{ $setup->{extensions} };
my $hash = {
name => $setup->{name} || $caller[0]{'sub'},
description => ( $setup->{description} || "Match a file extension" ),
fields => [ $setup->{field} ],
code => sub {
my $extension = Brick::_get_file_extension( $_[0]->{ $setup->{field} } );
die {
message => "[$_[0]->{ $setup->{field} }] did not have the right extension",
failed_field => $setup->{field},
failed_value => $_[0]->{ $setup->{field} },
handler => $caller[0]{'sub'},
} unless exists $extensions{ $extension };
},
};
$bucket->__make_constraint(
$bucket->add_to_bucket ( $hash )
);
}
=item is_clamav_clean( HASH_REF )
Passes if ClamAV doesn't complain about the file.
clamscan_location the location of ClamAV, or /usr/local/bin/clamscan
filename the filename to check
The filename can only contain word characters or a period.
=cut
sub is_clamav_clean {
my( $bucket, $setup ) = @_;
my @caller = $bucket->__caller_chain_as_list;
my $clamscan = $setup->{clamscan_location} || "/usr/local/bin/clamscan";
my $hash = {
name => $setup->{name} || $caller[0]{'sub'},
description => ( $setup->{description} || "Check for viruses" ),
fields => [ $setup->{field} ],
code => sub {
my( $input ) = @_;
die {
message => "Could not find clamscan",
failed_field => $setup->{clamscan_location},
failed_value => $_[0]->{ $setup->{clamscan_location} },
handler => $caller[0]{'sub'},
} unless -x $clamscan;
die {
message => "File name has odd characters",
failed_field => $setup->{filename},
failed_value => $_[0]->{ $setup->{filename} },
handler => $caller[0]{'sub'},
} unless $setup->{filename} =~ m/^[\w.]+\z/;
die {
message => "Could not find file to check for viruses",
failed_field => $setup->{filename},
failed_value => $_[0]->{ $setup->{filename} },
handler => $caller[0]{'sub'},
} unless -f $setup->{filename};
my $results = do {
local $ENV{PATH} = '';
`$clamscan --no-summary -i --stdout $setup->{filename}`;
};
die {
message => "ClamAV complained: $results",
failed_field => $setup->{filename},
failed_value => $_[0]->{ $setup->{filename} },
handler => $caller[0]{'sub'},
} if $results;
1;
},
};
$bucket->__make_constraint(
$bucket->add_to_bucket ( $hash )
);
}
=pod
sub file_clamav_clean {
my $clamscan = "/usr/local/bin/clamscan";
return sub {
my $dfv = shift;
$dfv->name_this('file_clamav_clean');
my $q = $dfv->get_input_data;
# Set $ENV{PATH} to the empty string to avoid taint error from
# exec call. Use local to temporarily clear it out in the context
# of this sub.
local $ENV{PATH} = q{};
$q->UNIVERSAL::can('param') or
die 'valid_file_clamav_clean: data object missing param() method';
my $field = $dfv->get_current_constraint_field;
my $img = $q->upload($field);
if (not $img and my $err = $q->cgi_error) {
warn $err;
return undef;
}
my $tmp_file = $q->tmpFileName($q->param($field)) or
(warn "$0: can't find tmp file for field named $field"),
return undef;
## now return true if $tmp_file is not a virus, false otherwise
unless (-x $clamscan) {
warn "$0: can't find clamscan, skipping test";
return 1; # it's valid because we don't see it
}
defined (my $pid = open KID, "-|") or die "Can't fork: $!";
unless ($pid) { # child does:
open STDIN, "<$tmp_file" or die "Cannot open $tmp_file for input: $!";
exec $clamscan, qw(--no-summary -i --stdout -);
die "Cannot find $clamscan: $!";
}
## parent does:
my $results = join '', <KID>;
close KID;
return if $results; ## if clamscan spoke, it's a virus
return 1;
};
}
=back
=head1 TO DO
Regex::Common support
=head1 SEE ALSO
TBA
=head1 SOURCE AVAILABILITY
This source is part of a SourceForge project which always has the
latest sources in CVS, as well as all of the previous releases.
http://sourceforge.net/projects/brian-d-foy/
If, for some reason, I disappear from the world, one of the other
members of the project can shepherd this module appropriately.
=head1 AUTHOR
brian d foy, C<< <bdfoy@cpan.org> >>
=head1 COPYRIGHT
Copyright (c) 2007, brian d foy, All Rights Reserved.
You may redistribute this under the same terms as Perl itself.
=cut
1;