CGI-Uploader-2.18/0000755000175000017500000000000011522150471012263 5ustar markmarkCGI-Uploader-2.18/create_uploader_table.mysql.sql0000644000175000017500000000054011522141350020450 0ustar markmarkCREATE TABLE uploads ( upload_id int AUTO_INCREMENT primary key not null, file_name character varying(255), mime_type character varying(64), extension character varying(8), -- file extension width integer, height integer, -- refer to the ID of the image used to create this thumbnail, if any gen_from_id integer ) CGI-Uploader-2.18/Makefile.PL0000644000175000017500000000744511522143314014245 0ustar markmarkuse strict; use warnings; use inc::Module::Install; # Module::Install stuff { no_index directory => 't/lib'; no_index file => 'examples/friends_photos/FriendsPhotos.pm'; license ('perl'); # Graphics::Magick is recommended over Image::Magick, but isn't on CPAN recommends 'Image::Magick' => 0; # This could probably become a "test_requires" requires 'Image::Size' => 0; } use Config (); use Getopt::Long(); use Data::Dumper (); my $TESTDB = "test"; use vars qw($opt); $opt = { "help" => \&Usage , testdsn => 'dbi:SQLite:dbname=t/test.db', }; Getopt::Long::GetOptions($opt, "help", "testdsn=s", "testuser=s","testpassword=s"); my $source = {}; for my $key (qw/testdsn testuser testpassword/) { Configure($opt, $source, $key); } print <<"MSG"; I will use the following settings for compiling and testing: MSG delete $opt->{'help'}; my $keylen = 0; for my $key (keys %$opt) { $keylen = length($key) if length($key) > $keylen; } my $slen = 0; for my $val (values %$source) { $slen = length($val) if length($val) > $slen; } for my $key (sort { $a cmp $b} keys %$opt) { printf(" %-" . $keylen . "s (%-" . $slen . "s) = %s\n", $key, $source->{$key}, $opt->{$key}) } print <<"MSG"; To change these settings, see 'perl Makefile.PL --help'. MSG #sleep 5; eval { require File::Spec }; my $fileName = $@ ? "t/cgi-uploader.config" : File::Spec->catfile("t", "cgi-uploader.config"); die "Failed to determine location of $fileName" unless -f $fileName; if (open(FILE, ">$fileName")) { print FILE '$dsn = q!'.$opt->{testdsn}."!;\n"; print FILE '$user = q!'.$opt->{testuser}."!;\n"; print FILE '$password = q!'.$opt->{testpassword}."!;\n"; print FILE "1;\n"; close(FILE) or die "Failed to create $fileName: $!"; } sub Configure { my($opt, $source, $param) = @_; if (exists($opt->{$param})) { $source->{$param} = "Users choice"; return; } elsif ($param eq "testuser" || $param eq "testpassword" || $param eq "testdsn") { $source->{$param} = "default"; $opt->{$param} = ""; } else { die "Unknown configuration parameter: $param"; } } sub Usage { print STDERR <<"USAGE"; Usage: perl $0 [options] Possible options are: --testdsn= Use the DBI datasource for running the test suite Postgres Example: dbi:Pg:dbname=\$db;host=\$host;username=\$user;password=\$pw MySQL Example: DBI:mysql:database=\$db;host=\$hostname --testuser= --testpassword= --help Print this message and exit Tables named "uploads" and "cgi_uploader_test" will be created and then removed. If a table by that name already exists, the tests will be skipped. USAGE exit 1; } use 5.008; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'CGI::Uploader', AUTHOR => 'Mark Stosberg ', 'VERSION_FROM' => 'lib/CGI/Uploader.pm', # finds $VERSION 'PREREQ_PM' => { 'Carp::Assert' => 0, 'CGI::Carp' => 0, 'Digest::MD5' => 0, 'File::Copy' => 0, 'File::Spec' => 0, 'File::MMagic' => 1.22, 'File::Path' => 0, 'MIME::Type' => 0, 'MIME::Types' => 0, 'Params::Validate' => 0.77, 'SQL::Abstract' => 0, 'CGI' => 0, 'DBI' => 0, 'DBD::SQLite' => 1.1, 'File::Temp' => 0.15, 'Test::DatabaseRow' => 0, 'HTTP::BrowserDetect' => 0.98, 'Scalar::Util' => 0, # For testing 'HTTP::Request::Common' => 0, }, ); CGI-Uploader-2.18/inc/0000755000175000017500000000000011522150471013034 5ustar markmarkCGI-Uploader-2.18/inc/Module/0000755000175000017500000000000011522150471014261 5ustar markmarkCGI-Uploader-2.18/inc/Module/Install/0000755000175000017500000000000011522150471015667 5ustar markmarkCGI-Uploader-2.18/inc/Module/Install/Makefile.pm0000644000175000017500000001007011522141350017734 0ustar markmark#line 1 "inc/Module/Install/Makefile.pm - /usr/local/lib/perl5/site_perl/5.8.0/Module/Install/Makefile.pm" package Module::Install::Makefile; use Module::Install::Base; @ISA = qw(Module::Install::Base); $VERSION = '0.01'; use strict 'vars'; use vars '$VERSION'; use ExtUtils::MakeMaker (); sub Makefile { $_[0] } sub prompt { shift; goto &ExtUtils::MakeMaker::prompt; } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join(" ", grep length, $clean->{FILES}, @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [shift]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); $args->{VERSION} = $self->version || $self->determine_VERSION($args); $args->{NAME} =~ s/-/::/g; # Only call $self->tests if we haven't been given explicit # tests from makemaker_args. $args->{test} ||= {TESTS => $self->tests}; if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 ) { $args->{SIGN} = 1 if $self->sign; } delete $args->{SIGN} unless $self->is_admin; # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->build_requires, $self->requires) ); # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if (my $perl_version = $self->perl_version) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, ". "but we need version >= $perl_version"; } my %args = map {($_ => $args->{$_})} grep {defined($args->{$_})} keys %$args; if ($self->admin->preop) { $args{dist} = $self->admin->preop; } ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile(); } sub fix_up_makefile { my $self = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, '< Makefile' or die $!; my $makefile = do { local $/; }; close MAKEFILE; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 -Iinc/m; $makefile =~ s/^(PERL = .*)/$1 -Iinc/m; open MAKEFILE, '> Makefile' or die $!; print MAKEFILE "$preamble$makefile$postamble"; close MAKEFILE; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 290 CGI-Uploader-2.18/inc/Module/Install/MakeMaker.pm0000644000175000017500000000211011522141350020050 0ustar markmark#line 1 "inc/Module/Install/MakeMaker.pm - /usr/local/lib/perl5/site_perl/5.8.0/Module/Install/MakeMaker.pm" package Module::Install::MakeMaker; use Module::Install::Base; @ISA = qw(Module::Install::Base); $VERSION = '0.01'; use ExtUtils::MakeMaker (); my $makefile; sub WriteMakefile { my ($self, %args) = @_; $makefile = $self->load('Makefile'); # mapping between MakeMaker and META.yml keys $args{MODULE_NAME} = $args{NAME}; unless ($args{NAME} = $args{DISTNAME} or !$args{MODULE_NAME}) { $args{NAME} = $args{MODULE_NAME}; $args{NAME} =~ s/::/-/g; } foreach my $key (qw(name module_name version version_from abstract author)) { my $value = delete($args{uc($key)}) or next; $self->$key($value); } if (my $prereq = delete($args{PREREQ_PM})) { while (my($k,$v) = each %$prereq) { $self->requires($k,$v); } } # put the remaining args to makemaker_args $self->makemaker_args(%args); } END { if ($makefile) { $makefile->write; $makefile->Meta->write; } } 1; CGI-Uploader-2.18/inc/Module/Install/Base.pm0000644000175000017500000000201111522141350017065 0ustar markmark#line 1 "inc/Module/Install/Base.pm - /usr/local/lib/perl5/site_perl/5.8.0/Module/Install/Base.pm" package Module::Install::Base; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w } }; #line 31 sub new { my ($class, %args) = @_; foreach my $method (qw(call load)) { *{"$class\::$method"} = sub { +shift->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless(\%args, $class); } #line 49 sub AUTOLOAD { my $self = shift; goto &{$self->_top->autoload}; } #line 60 sub _top { $_[0]->{_top} } #line 71 sub admin { my $self = shift; $self->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { my $self = shift; $self->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} 1; # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->() }; __END__ #line 118 CGI-Uploader-2.18/inc/Module/Install/Metadata.pm0000644000175000017500000002220611522141350017743 0ustar markmark#line 1 "inc/Module/Install/Metadata.pm - /usr/local/lib/perl5/site_perl/5.8.0/Module/Install/Metadata.pm" package Module::Install::Metadata; use Module::Install::Base; @ISA = qw(Module::Install::Base); $VERSION = '0.04'; use strict 'vars'; use vars qw($VERSION); sub Meta { shift } my @scalar_keys = qw< name module_name version abstract author license distribution_type perl_version tests >; my @tuple_keys = qw< build_requires requires recommends bundles >; foreach my $key (@scalar_keys) { *$key = sub { my $self = shift; return $self->{'values'}{$key} unless @_; $self->{'values'}{$key} = shift; return $self; }; } sub sign { my $self = shift; $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); return $self; } foreach my $key (@tuple_keys) { *$key = sub { my $self = shift; return $self->{'values'}{$key} unless @_; my @rv; while (@_) { my $module = shift or last; my $version = shift || 0; if ( $module eq 'perl' ) { $version =~ s{^(\d+)\.(\d+)\.(\d+)} {$1 + $2/1_000 + $3/1_000_000}e; $self->perl_version($version); next; } my $rv = [ $module, $version ]; push @rv, $rv; } push @{ $self->{'values'}{$key} }, @rv; @rv; }; } sub all_from { my ( $self, $file ) = @_; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; # The remaining probes read from POD sections; if the file # has an accompanying .pod, use that instead my $pod = $file; if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) { $file = $pod; } $self->author_from($file) unless $self->author; $self->license_from($file) unless $self->license; $self->abstract_from($file) unless $self->abstract; } sub provides { my $self = shift; my $provides = ( $self->{'values'}{'provides'} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } require Module::Build; my $build = Module::Build->new( dist_name => $self->{name}, dist_version => $self->{version}, license => $self->{license}, ); $self->provides(%{ $build->find_dist_packages || {} }); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{'values'}{'features'} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return @{ $self->{'values'}{'features'} }; } sub no_index { my $self = shift; my $type = shift; push @{ $self->{'values'}{'no_index'}{$type} }, @_ if $type; return $self->{'values'}{'no_index'}; } sub _dump { my $self = shift; my $package = ref( $self->_top ); my $version = $self->_top->VERSION; my %values = %{ $self->{'values'} }; delete $values{sign}; if ( my $perl_version = delete $values{perl_version} ) { # Always canonical to three-dot version $perl_version =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e if $perl_version >= 5.006; $values{requires} = [ [ perl => $perl_version ], @{ $values{requires} || [] }, ]; } warn "No license specified, setting license = 'unknown'\n" unless $values{license}; $values{license} ||= 'unknown'; $values{distribution_type} ||= 'module'; $values{name} ||= do { my $name = $values{module_name}; $name =~ s/::/-/g; $name; } if $values{module_name}; if ( $values{name} =~ /::/ ) { my $name = $values{name}; $name =~ s/::/-/g; die "Error in name(): '$values{name}' should be '$name'!\n"; } my $dump = ''; foreach my $key (@scalar_keys) { $dump .= "$key: $values{$key}\n" if exists $values{$key}; } foreach my $key (@tuple_keys) { next unless exists $values{$key}; $dump .= "$key:\n"; foreach ( @{ $values{$key} } ) { $dump .= " $_->[0]: $_->[1]\n"; } } if ( my $provides = $values{provides} ) { require YAML; local $YAML::UseHeader = 0; $dump .= YAML::Dump( { provides => $provides } ); } if ( my $no_index = $values{no_index} ) { push @{ $no_index->{'directory'} }, 'inc'; require YAML; local $YAML::UseHeader = 0; $dump .= YAML::Dump( { no_index => $no_index } ); } else { $dump .= << "META"; no_index: directory: - inc META } $dump .= "generated_by: $package version $version\n"; return $dump; } sub read { my $self = shift; $self->include_deps( 'YAML', 0 ); require YAML; my $data = YAML::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; META_NOT_OURS: { local *FH; if ( open FH, "META.yml" ) { while () { last META_NOT_OURS if /^generated_by: Module::Install\b/; } return $self if -s FH; } } print "Writing META.yml\n"; local *META; open META, "> META.yml" or warn "Cannot write to META.yml: $!"; print META $self->_dump; close META; return $self; } sub version_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' ) ->parse_abstract($file) ); } sub _slurp { my ( $self, $file ) = @_; local *FH; open FH, "< $file" or die "Cannot open $file.pod: $!"; do { local $/; }; } sub perl_version_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ^ use \s* v? ([\d\.]+) \s* ; /ixms ) { $self->perl_version($1); } else { warn "Cannot determine perl version info from $file\n"; return; } } sub author_from { my ( $self, $file ) = @_; my $content = $self->_slurp($file); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $file\n"; } } sub license_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b (.*?) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as perl itself' => 'perl', 'GNU public license' => 'gpl', 'GNU lesser public license' => 'gpl', 'BSD license' => 'bsd', 'Artistic license' => 'artistic', 'GPL' => 'gpl', 'LGPL' => 'lgpl', 'BSD' => 'bsd', 'Artistic' => 'artistic', ); while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $file\n"; return 'unknown'; } 1; CGI-Uploader-2.18/inc/Module/Install.pm0000644000175000017500000001203211522141350016217 0ustar markmark#line 1 "/usr/home/mark/perl/uploader/inc/Module/Install.pm - /usr/local/lib/perl5/site_perl/5.8.0/Module/Install.pm" package Module::Install; use 5.004; $VERSION = '0.45'; die << "." unless $INC{join('/', inc => split(/::/, __PACKAGE__)).'.pm'}; Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; . use strict 'vars'; use Cwd qw(cwd abs_path); use FindBin; use File::Find (); use File::Path (); @inc::Module::Install::ISA = 'Module::Install'; *inc::Module::Install::VERSION = *VERSION; sub autoload { my $self = shift; my $caller = $self->_caller; my $cwd = cwd(); my $sym = "$caller\::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = cwd(); if (my $code = $sym->{$pwd}) { goto &$code unless $cwd eq $pwd; # delegate back to parent dirs } $$sym =~ /([^:]+)$/ or die "Cannot autoload $caller - $sym"; unshift @_, ($self, $1); goto &{$self->can('call')} unless uc($1) eq $1; }; } sub import { my $class = shift; my $self = $class->new(@_); if (not -f $self->{file}) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new(_top => $self); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{$self->_caller . "::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; } sub preload { my ($self) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; my @exts = @{$self->{extensions}}; unless (@exts) { my $admin = $self->{admin}; @exts = $admin->load_all_extensions; } my %seen_method; foreach my $obj (@exts) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless defined *{$glob}{CODE}; next if $method =~ /^_/; next if $method eq uc($method); $seen_method{$method}++; } } my $caller = $self->_caller; foreach my $name (sort keys %seen_method) { *{"${caller}::$name"} = sub { ${"${caller}::AUTOLOAD"} = "${caller}::$name"; goto &{"${caller}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = abs_path($FindBin::Bin); delete $args{prefix} unless abs_path(cwd()) eq $base_path; return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= '.author'; $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ($args{path}) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; bless(\%args, $class); } sub call { my $self = shift; my $method = shift; my $obj = $self->load($method) or return; unshift @_, $obj; goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die << "END"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top_obj) = @_; unshift @INC, $self->{prefix} unless grep { $_ eq $self->{prefix} } @INC; local @INC = ($path, @INC); foreach my $rv ($self->find_extensions($path)) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; if (!$new) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top_obj ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find(sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; return if $1 eq $self->{dispatch}; $file = "$self->{path}/$1.pm"; my $pkg = "$self->{name}::$1"; $pkg =~ s!/!::!g; push @found, [$file, $pkg]; }, $path) if -d $path; @found; } sub _caller { my $depth = 0; my $caller = caller($depth); while ($caller eq __PACKAGE__) { $depth++; $caller = caller($depth); } $caller; } 1; CGI-Uploader-2.18/examples/0000755000175000017500000000000011522150471014101 5ustar markmarkCGI-Uploader-2.18/examples/friends_photos/0000755000175000017500000000000011522150471017127 5ustar markmarkCGI-Uploader-2.18/examples/friends_photos/friends.Pg.sql0000644000175000017500000000131511522141350021643 0ustar markmark-- arch-tag: cf379bd5-b773-481f-b026-38932dbb9c78 -- Note the Postgres specific syntax here CREATE SEQUENCE upload_id_seq; CREATE TABLE uploads ( upload_id int primary key not null default nextval('upload_id_seq'), mime_type character varying(64), extension character varying(8), -- file extension width integer, height integer, thumbnail_of_id integer ); CREATE SEQUENCE friend_id_seq; CREATE TABLE address_book ( friend_id int primary key NOT NULL DEFAULT nextval('friend_id_seq'), full_name varchar(64), -- these two reference uploads('upload_id'), photo_id int, photo_thumbnail_id int ); CGI-Uploader-2.18/examples/friends_photos/FriendsPhotos.pm0000644000175000017500000000652711522141350022262 0ustar markmarkpackage FriendsPhotos; use base 'CGI::Application'; use strict; use lib ('../../lib','/usr/share/perl5'); use CGI::Application::ValidateRM; use CGI::Uploader; sub setup { my $self = shift; $self->start_mode('add_form'); $self->run_modes([qw/ add_form add_process edit_form edit_process /]); my $uploader_args = $self->param('uploader_args') || die "must pass uploader PARAM"; my $u = CGI::Uploader->new(%$uploader_args); $self->param('uploader',$u); } sub add_form { my $self = shift; my $t = $self->load_tmpl('photo-add.html'); return $t->output; }; sub add_process { my $self = shift; my $q = $self->query; my $query_hash = $q->Vars; my $dbh = $self->param('dbh'); my $u = $self->param('uploader'); my ($results, $err_page) = $self->check_rm('add_form', { required => [qw/full_name photo/], msgs => { prefix => 'err_' }, }); return $err_page if $err_page; my $valid = $results->valid; my $friend; eval { $dbh->{RaiseError} = 1; $valid->{friend_id} = $dbh->selectrow_array("SELECT nextval('friend_id_seq')"); $friend = $u->store_uploads($valid); require SQL::Abstract; my $sql = SQL::Abstract->new; my($stmt, @bind) = $sql->insert('address_book',$friend); $dbh->do($stmt,{},@bind); }; if ($@) { return "failure: $@"; } else { my $new_q = CGI->new({ success => 1, rm => 'edit_form', friend_id => $friend->{friend_id} } ); $self->header_type('redirect'); $self->header_props( -url=> $ENV{SCRIPT_NAME}.'?'.$new_q->query_string ); } } sub edit_form { my $self = shift; my $msgs = shift; my $q = $self->query; my $dbh = $self->param('dbh'); my $friend_id = $q->param('friend_id'); die "no friend_id found" unless $friend_id; my $t = $self->load_tmpl('photo-edit.html',die_on_bad_params=>0,); $t->param($msgs) if $msgs; $t->param(msg => $q->param('msg')); my $friend = $dbh->selectrow_hashref("SELECT * FROM address_book WHERE friend_id = ?",{},$friend_id); if ($friend->{photo_id}) { my $u = $self->param('uploader'); my $href = $u->fk_meta( table => 'address_book', where => { friend_id => $friend_id }, prefixes => [qw/photo photo_thumbnail/]); $t->param($href); } require HTML::FillInForm; my $fif = HTML::FillInForm->new(); return $fif->fill(scalarref=>\$t->output,fdat=>$friend); } sub edit_process { my $self = shift; my ($results, $err_page) = $self->check_rm('edit_form', { require_some => { photo_or_photo_id => [qw/photo photo_id/], }, required => [qw/full_name friend_id/], msgs => { prefix => 'err_' }, }); return $err_page if $err_page; my $dbh = $self->param('dbh'); my $q = $self->query; my $u = $self->param('uploader'); my $friend = $results->valid; eval { $dbh->{RaiseError} = 1; my @fk_names = $u->delete_checked_uploads; map { $friend->{$_} = undef } @fk_names; delete $friend->{photo_delete}; $friend = $u->store_uploads($friend); require SQL::Abstract; my $sql = SQL::Abstract->new(); my ($stmt,@bind) = $sql->update('address_book',$friend, { friend_id => $friend->{friend_id} }); $dbh->do($stmt,{},@bind); }; if ($@) { return "Failure: $@"; } else { my $new_q = CGI->new({ success => 1, rm => 'edit_form', friend_id => $friend->{friend_id} } ); $self->header_type('redirect'); $self->header_props( -url=> $ENV{SCRIPT_NAME}.'?'.$new_q->query_string ); } } 1; CGI-Uploader-2.18/examples/friends_photos/photo-edit.html0000644000175000017500000000174111522141350022070 0ustar markmark Update a Photo of a Friend

Friend Added Successfully.

Update a Photo of a Friend

Friend Name:

Current Image
Delete Image?


Image:
CGI-Uploader-2.18/examples/friends_photos/photos.cgi0000755000175000017500000000155211522141350021131 0ustar markmark#!/usr/bin/perl # arch-tag: e4d2fb56-ed1d-468d-8b54-96f1d6de9f78 # You may need to adjust to this to point to where your CGI::Uploader is stored. use lib '../../lib'; use CGI::Carp qw(fatalsToBrowser); package FriendsPhotos; use strict; use FriendsPhotos; use File::Basename; my $script_dir = dirname($0); my $script_url = dirname($ENV{SCRIPT_NAME}); use DBI; # ADJUST ME my $dbh = DBI->connect('dbi:Pg:dbname=mark','mark'); use CGI::Uploader::Transform::ImageMagick; my $app = FriendsPhotos->new( PARAMS => { dbh => $dbh, uploader_args => { spec => { photo => { gen_files => { photo_thumbnail => gen_thumb({ w => 100, h => 100}), } } }, updir_url => "$script_url/uploads", updir_path => "$script_dir/uploads", dbh => $dbh, }, } ); $app->run(); CGI-Uploader-2.18/examples/friends_photos/uploads/0000755000175000017500000000000011522150471020576 5ustar markmarkCGI-Uploader-2.18/examples/friends_photos/uploads/.empty0000644000175000017500000000000011522141350021717 0ustar markmarkCGI-Uploader-2.18/examples/friends_photos/README0000644000175000017500000000136011522141350020003 0ustar markmark PREREQUISIITES The following additional modules (plus their own dependencies) are required for this example application: CGI::Application HTML::Template CGI::Application::ValidateRM SQL::Abstract INSTALLATION In photos.cgi, you need configure your DBI connection parameters, and possibly adjust the 'use lib' line so that it can find CGI::UPloader. CLEAN UP Once you are done playing with the application, you may wish to clean up the database. Assuming you've used these resources only for this example, you can clean up easily: - delete all the images in the 'uploads' sub-directory. - delete all the rows from address_book() and uploads() tables. # do not disturb the line below.. Thanks # arch-tag: b70d1f18-3303-47c8-ac90-64385d483f44 CGI-Uploader-2.18/examples/friends_photos/photo-add.html0000644000175000017500000000117311522141350021672 0ustar markmark Add a Photo of a Friend

Add a Photo of a Friend

Friend Name:
Image:
CGI-Uploader-2.18/MANIFEST0000644000175000017500000000152611522141350013414 0ustar markmarkChanges MANIFEST Makefile.PL create_uploader_table.Pg.sql create_uploader_table.mysql.sql create_uploader_table.SQLite.sql lib/CGI/Uploader.pm lib/CGI/Uploader/Cookbook.pod lib/CGI/Uploader/Transform/ImageMagick.pm t/lib/CGI/Uploader/Test.pm t/200x200.gif t/20x16.png t/basic.t t/build_loc.t t/cgi-simple.t t/cgi-uploader.config t/create_test_table.sql t/gen_thumb.t t/meta.t t/pod.t t/up_table_map.t t/uploads/.empty t/tmp/.empty t/test_file.txt examples/friends_photos/uploads/.empty examples/friends_photos/README examples/friends_photos/photos.cgi examples/friends_photos/FriendsPhotos.pm examples/friends_photos/photo-add.html examples/friends_photos/photo-edit.html examples/friends_photos/friends.Pg.sql inc/Module/Install.pm inc/Module/Install/Metadata.pm inc/Module/Install/Base.pm inc/Module/Install/MakeMaker.pm inc/Module/Install/Makefile.pm CGI-Uploader-2.18/lib/0000755000175000017500000000000011522150471013031 5ustar markmarkCGI-Uploader-2.18/lib/CGI/0000755000175000017500000000000011522150471013433 5ustar markmarkCGI-Uploader-2.18/lib/CGI/Uploader.pm0000644000175000017500000011532111522150256015550 0ustar markmarkpackage CGI::Uploader; use 5.008; use strict; use Carp; use Params::Validate ':all'; use File::Path; use File::Spec; use File::Temp 'tempfile'; use Carp::Assert; use Image::Size; require Exporter; our $VERSION = '2.18'; =head1 NAME CGI::Uploader - Manage CGI uploads using SQL database =head1 Synopsis use CGI::Uploader::Transform::ImageMagick 'gen_thumb'; my $u = CGI::Uploader->new( spec => { # Upload one image named from the form field 'img' # and create one thumbnail for it. img_1 => { gen_files => { 'img_1_thmb_1' => gen_thumb({ w => 100, h => 100 }), } }, }, updir_url => 'http://localhost/uploads', updir_path => '/home/user/www/uploads', temp_dir => '/home/user/www/uploads', dbh => $dbh, query => $q, # defaults to CGI->new(), ); # ... now do something with $u =head1 Description This module is designed to help with the task of managing files uploaded through a CGI application. The files are stored on the file system, and the file attributes stored in a SQL database. =head1 Introduction and Recipes The L provides a slightly more in depth introduction and recipes for a basic BREAD web application. (Browse, Read, Edit, Add, Delete). =head1 Constructor =head2 new() my $u = CGI::Uploader->new( spec => { # The first image has 2 different sized thumbnails img_1 => { gen_files => { 'img_1_thmb_1' => gen_thumb({ w => 100, h => 100 }), 'img_1_thmb_2' => gen_thumb({ w => 50, h => 50 }), } }, }, # Just upload it img_2 => {}, # Downsize the large image to these maximum dimensions if it's larger img_3 => { # Besides generating dependent files # We can also transform the file itself # Here, we shrink the image to be wider than 380 transform_method => \&gen_thumb, # demostrating the old-style param passing params => [{ w => 380 }], } }, updir_url => 'http://localhost/uploads', updir_path => '/home/user/www/uploads', dbh => $dbh, query => $q, # defaults to CGI->new(), up_table => 'uploads', # defaults to "uploads" up_seq => 'upload_id_seq', # Required for Postgres ); =over 4 =item spec [required] The specification described the examples above. The keys correspond to form field names for upload fields. The values are hash references. The simplest case is an empty hash reference, which means to just upload the image and apply no transformations. ##### Each key in the hash is the corresponds to a file upload field. The values are hash references used provide options for how to transform the file, and possibly generate additional files based on it. Valid keys here are: =item transform_method This is a subroutine reference. This routine can be used to transform the upload before it is stored. The first argument given to the routine will be the CGI::Uploader object. The second will be a full path to a file name containing the upload. Additional arguments can be passed to the subroutine using C, as in the example above. But don't do that, it's ugly. If you need a custom transform method, write a little closure for it like this: sub my_transformer { my %args = @_; return sub { my ($self, $file) = shift; # do something with $file and %args here... return $path_to_new_file_i_made; } Then in the spec you can put: transform_method => my_tranformer(%args), It must return a full path to a transformed file. } =item params (DEPRECATED) B Using a closure based interface provides a cleaner alternative to using params. See L for an example. Used to pass additional arguments to C. See above. Each method used may have additional documentation about parameters that can be passed to it. =item gen_files A hash reference to describe files generated from a particular upload. The keys are unique identifiers for the generated files. The values are code references (usually closures) that prove a transformation for the file. See L for an an example. An older interface for C is deprecated. For that, the values are hashrefs, containing keys named C and C, which work as described above to generate a transformed version of the file. =item updir_url [required] URL to upload storage directory. Should not include a trailing slash. =item updir_path [required] File system path to upload storage directory. Should not include a trailing slash. =item temp_dir Optional file system path to temporary directory. Default is File::Spec->tmpdir(). This temporary directory will also be used by gen_files during image transforms. =item dbh [required] DBI database handle. Required. =item query A CGI.pm-compatible object, used for the C and C functions. Defaults to CGI->new() if omitted. =item up_table Name of the SQL table where uploads are stored. See example syntax above or one of the creation scripts included in the distribution. Defaults to "uploads" if omitted. =item up_table_map A hash reference which defines a mapping between the column names used in your SQL table, and those that CGI::Uploader uses. The keys are the CGI::Uploader default names. Values are the names that are actually used in your table. This is not required. It simply allows you to use custom column names. upload_id => 'upload_id', mime_type => 'mime_type', extension => 'extension', width => 'width', height => 'height', gen_from_id => 'gen_from_id', file_name => 'file_name', You may also define additional column names with a value of 'undef'. This feature is only useful if you override the C method or pass in C<$shared_meta> to store_uploads(). Values for these additional columns will then be stored by C and retrieved with C. =item up_seq For Postgres only, the name of a sequence used to generate the upload_ids. Defaults to C if omitted. =item file_scheme file_scheme => 'md5', C controls how file files are stored on the file system. The default is C, which stores all the files in the same directory with names like C<123.jpg>. Depending on your environment, this may be sufficient to store 10,000 or more files. As an alternative, you can specify C, which will create three levels of directories based on the first three letters of the ID's md5 sum. The result may look like this: 2/0/2/123.jpg This should scale well to millions of files. If you want even more control, consider overriding the C method, which is used to return the stored file path. Note that specifying the file storage scheme for the file system is not related to the C stored in the database, which is always the original uploaded file name. =back =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my %in = validate( @_, { updir_url => { type => SCALAR }, updir_path => { type => SCALAR }, dbh => 1, up_table => { type => SCALAR, default=> 'uploads', }, temp_dir => { type => SCALAR, default => File::Spec->tmpdir() }, up_table_map => { type => HASHREF, default => { upload_id => 'upload_id', mime_type => 'mime_type', extension => 'extension', width => 'width', height => 'height', gen_from_id => 'gen_from_id', # bytes => 'bytes', } }, up_seq => { default => 'upload_id_seq'}, spec => { type => HASHREF }, query => { optional => 1 } , file_scheme => { regex => qr/^simple|md5$/, default => 'simple', }, }); $in{db_driver} = $in{dbh}->{Driver}->{Name}; # Support PostgreSQL via ODBC $in{db_driver} = 'Pg' if $in{dbh}->get_info(17) eq 'PostgreSQL'; unless (($in{db_driver} eq 'mysql') or ($in{db_driver} eq 'Pg') or ($in{db_driver} eq 'SQLite')) { croak "only mysql, Pg and SQLite drivers are supported at this time. You are trying to use $in{db_driver}."; } unless ($in{query}) { require CGI; $in{query} = CGI->new; } # Process the spec for my $k (keys %{ $in{spec} }) { # If the spec is an arrayref, that's a shorthand for specifying some gen_files. if (ref $in{spec}->{$k} eq 'ARRAY') { $in{spec}->{$k} = { gen_files => $in{spec}->{$k}, }; } } # Fill in missing map values for (keys %{ $in{up_table_map} }) { $in{up_table_map}{$_} = $_ unless defined $in{up_table_map}{$_}; } # keep pointer to input hash for easier re-use later $in{input} =\%in; my $self = \%in; bless ($self, $class); return $self; } =head1 Basic Methods These basic methods are all you need to know to make effective use of this module. =head2 store_uploads() my $entity = $u->store_uploads($form_data); Stores uploaded files based on the definition given in C. Specifically, it does the following: =over =item o possibily transforms the original file according to C =item o possibly generates additional files based on those uploaded, according to C. =item o stores all the files on the file system =item o inserts upload details into the database, including upload_id, mime_type and extension. The columns 'width' and 'height' will be populated if that meta data is available. =back As input, a hash reference of form data is expected. The simplest way to get this is like this: use CGI; my $q = new CGI; $form_data = $q->Vars; However, I recommend that you validate your data with a module with L, and use a hash reference of validated data, instead of directly using the CGI form data. CGI::Uploader is designed to handle uploads that are included as a part of an add/edit form for an entity stored in a database. So, C<$form_data> is expected to contain additional fields for this entity as well as the file upload fields. For this reason, the C method returns a hash reference of the valid data with some transformations. File upload fields will be removed from the hash, and corresponding "_id" fields will be added. So for a file upload field named 'img_field', the 'img_field' key will be removed from the hash and 'img_field_id' will be added, with the appropriate upload ID as the value. store_uploads takes an optional second argument as well: my $entity = $u->store_uploads($form_data,$shared_meta); This is a hash refeference of additional meta data that you want to store for all of the images you storing. For example, you may wish to store an "uploaded_user_id". The keys should be column names that exist in your C table. The values should be appropriate data for the column. Only the key names defined by the C in C will be used. Other values in the hash will be ignored. =cut sub store_uploads { validate_pos(@_,1,1,0); my $self = shift; my $form_data = shift; my $shared_meta = shift; assert($form_data, 'store_uploads: input hashref missing'); my $uploads = $self->{spec}; my %entity_all_extra; for my $file_field (keys %$uploads) { # If we have an uploaded file for this my ($tmp_filename,$uploaded_mt,$file_name) = $self->upload($file_field); if ($tmp_filename) { my $id_to_update = $form_data->{$file_field.'_id'}; my %entity_upload_extra = $self->store_upload( file_field => $file_field, src_file => $tmp_filename, uploaded_mt => $uploaded_mt, file_name => $file_name, shared_meta => $shared_meta, id_to_update => $id_to_update, ); %entity_all_extra = (%entity_all_extra, %entity_upload_extra); } } # Now add and delete as needed my $entity = { %$form_data, %entity_all_extra }; map { delete $entity->{$_} } keys %{ $self->{spec} }; # For good measure. delete $entity->{''}; File::Temp::cleanup(); return $entity; } =head2 delete_checked_uploads() my @fk_col_names = $u->delete_checked_uploads; This method deletes all uploads and any generated files based on form input. Both files and meta data are removed. It looks through all the field names defined in C. For an upload named I, a field named I is checked to see if it has a true value. A list of the field names is returned, prepended with '_id', such as: img_1_id The expectation is that you have foreign keys with these names defined in another table. Having the names is format allows you to easily set these fields to NULL in a database update: map { $entity->{$_} = undef } @fk_names; B This method can not currently be used to delete a generated file by itself. =cut sub delete_checked_uploads { my $self = shift; my $imgs = $self->{spec}; my $q = $self->{query}; my $map = $self->{up_table_map}; croak "missing gen_from_id in up_table_map" unless $map->{gen_from_id}; my @to_delete; for my $file_field (keys %$imgs) { if ($q->param($file_field.'_delete') ) { my $upload_id = $q->param($file_field.'_id') || croak "$file_field was selected to delete, but ID was missing in '${file_field}_id' field"; $self->delete_upload($upload_id); # Delete generated files as well. my $gen_file_ids = $self->{dbh}->selectcol_arrayref( "SELECT $map->{upload_id} FROM $self->{up_table} WHERE $map->{gen_from_id} = ?",{},$upload_id) || []; for my $gen_file_id (@$gen_file_ids) { $self->delete_upload($gen_file_id); } push @to_delete, map {$_.'_id'} $self->spec_names($file_field) ; } } return @to_delete; } =head2 fk_meta() my $href = $u->fk_meta( table => $table, where => \%where, prefixes => \@prefixes, Returns a hash reference of information about the file, useful for passing to a templating system. Here's an example of what the contents of C<$href> might look like: { file_1_id => 523, file_1_url => 'http://localhost/images/uploads/523.pdf', } If the files happen to be images and have their width and height defined in the database row, template variables will be made for these as well. This is going to fetch the file information from the upload table for using the row where news.item_id = 23 AND news.file_1_id = uploads.upload_id. This is going to fetch the file information from the upload table for using the row where news.item_id = 23 AND news.file_1_id = uploads.upload_id. The C<%where> hash mentioned here is a L where clause. The complete SQL that used to fetch the data will be built like this: SELECT upload_id as id,width,height,extension FROM uploads, $table WHERE (upload_id = ${prefix}_id AND (%where_clause_expanded here)); =cut sub fk_meta { my $self = shift; my %p = validate(@_,{ table => { type => SCALAR }, where => { type => HASHREF }, prefixes => { type => ARRAYREF }, prevent_browser_caching => { default => 1 } }); my $table = $p{table}; my $where = $p{where}; my @file_fields = @{ $p{prefixes} }; my $DBH = $self->{dbh}; my %fields; require SQL::Abstract; my $sql = SQL::Abstract->new; my ($stmt,@bind) = $sql->where($where); # We don't want the 'WHERE' word that SQL::Abstract adds $stmt =~ s/^\s?WHERE//; # XXX There is probably a more efficient way to get this data than using N selects # mysql uses non-standard quoting my $qt = ($DBH->{Driver}->{Name} eq 'mysql') ? '`' : '"'; my $map = $self->{up_table_map}; for my $field (@file_fields) { my $upload = $DBH->selectrow_hashref(qq! SELECT * FROM !.$self->{up_table}.qq!, $table AS t WHERE ($self->{up_table}.$map->{upload_id} = t.${qt}${field}_id${qt} and ($stmt) )!, {},@bind); my %upload_fields = $self->transform_meta( meta => $upload, prevent_browser_caching => $p{prevent_browser_caching}, prefix => $field, ); %fields = (%fields, %upload_fields); } return \%fields; } =head1 Class Methods These are some handy class methods that you can use without the need to first create an object using C. =head2 upload() # As a class method ($tmp_filename,$uploaded_mt,$file_name) = CGI::Uplooader->upload('file_field',$q); # As an object method ($tmp_filename,$uploaded_mt,$file_name) = $u->upload('file_field'); The function is responsible for actually uploading the file. It can be called as a class method or an object method. As a class method, it's necessary to provide a query object as the second argument. As an object method, the query object given the constructor is used. Input: - file field name Output: - temporary file name - Uploaded MIME Type - Name of uploaded file (The value of the file form field) Currently CGI.pm, CGI::Simple and Apache::Request and are supported. =cut sub upload { my $self = shift; my $file_field = shift; my $q = shift || $self->{query}; my $fh; my $mt = ''; my $filename = $q->param($file_field); if ($q->isa('CGI::Simple') ) { local $CGI::Simple::DISABLE_UPLOADS = 0; # Having uploads enabled is mandatory for this to work. $fh = $q->upload($filename); $mt = $q->upload_info($filename, 'mime' ); if (!$fh && $q->cgi_error) { warn $q->cgi_error && return undef; } } elsif ( $q->isa('Apache::Request') ) { my $upload = $q->upload($file_field); $fh = $upload->fh; $mt = $upload->type; } # default to CGI.pm behavior else { local $CGI::DISABLE_UPLOADS = 0; # Having uploads enabled is mandatory for this to work. $fh = $q->upload($file_field); $mt = $q->uploadInfo($fh)->{'Content-Type'} if $q->uploadInfo($fh); if (!$fh && $q->cgi_error) { warn $q->cgi_error && return undef; } } return undef unless ($fh && $filename); my ($tmp_fh, $tmp_filename) = tempfile('CGIuploaderXXXXX', UNLINK => 1, DIR => $self->{'temp_dir'} ); binmode($fh); require File::Copy; import File::Copy; copy($fh,$tmp_filename) || croak "upload: unable to create tmp file: $!"; return ($tmp_filename,$mt,$filename); } =head1 Upload Methods These methods are high level methods to manage the file and meta data parts of an upload, as well its generated files. If you are doing something more complex or customized you may want to call or overide one of the below methods. =head2 store_upload() my %entity_upload_extra = $u->store_upload( file_field => $file_field, src_file => $tmp_filename, uploaded_mt => $uploaded_mt, file_name => $file_name, shared_meta => $shared_meta, # optional id_to_update => $id_to_update, # optional ); Does all the processing for a single upload, after it has been uploaded to a temp file already. It returns a hash of key/value pairs as described in L. =cut sub store_upload { my $self = shift; my %p = validate(@_, { file_field => { type => SCALAR }, src_file => { type => SCALAR }, uploaded_mt => { type => SCALAR }, file_name => { type => SCALAR | GLOBREF }, shared_meta => { type => HASHREF | UNDEF, default => {} }, id_to_update => { type => SCALAR | UNDEF, optional => 1 }, }); my ( $file_field, $tmp_filename, $uploaded_mt, $file_name, $shared_meta, $id_to_update, ) = ($p{file_field},$p{src_file},$p{uploaded_mt},$p{file_name},$p{shared_meta},$p{id_to_update}); # Transform file if needed if (my $meth = $self->{spec}{$file_field}{transform_method}) { $tmp_filename = $meth->( $self, $tmp_filename, $self->{spec}{$file_field}{params}, ); } # XXX The uploaded mime type may have nothing to do with # the current mime-type after it's transformed my $meta = $self->extract_meta($tmp_filename,$file_name,$uploaded_mt); $shared_meta ||= {}; my $all_meta = { %$meta, %$shared_meta }; my $id; # If it's an update if ($id = $id_to_update) { # delete old generated files before we create new ones $self->delete_gen_files($id); # It's necessary to delete the old file when updating, because # the new one may have a new extension. $self->delete_file($id); } # insert or update will be performed as appropriate. $id = $self->store_meta( $file_field, $all_meta, $id ); $self->store_file($file_field,$id,$meta->{extension},$tmp_filename); my %ids = (); %ids = $self->create_store_gen_files( file_field => $file_field, meta => $all_meta, src_file => $tmp_filename, gen_from_id => $id, ); return (%ids, $file_field.'_id' => $id); } =head2 create_store_gen_files() my %gen_file_ids = $u->create_store_gen_files( file_field => $file_field, meta => $meta_href, src_file => $tmp_filename, gen_from_id => $gen_from_id, ); This method is responsible for creating and storing any needed thumbnails. Input: - file_field: file field name - meta: a hash ref of meta data, as C would produce - src_file: path to temporary file of the file upload - gen_from_id: ID of upload that generated files will be made from =cut sub create_store_gen_files { my $self = shift; my %p = validate(@_, { file_field => { type => SCALAR }, src_file => { type => SCALAR }, meta => { type => HASHREF | UNDEF, default => {} }, gen_from_id => { regex => qr/^\d*$/, }, }); my ($file_field, $meta, $tmp_filename, $gen_from_id) = ($p{file_field},$p{meta},$p{src_file},$p{gen_from_id}); my $gen_fields_key = $self->{spec}{$file_field}{gen_files} || return undef; my @gen_files = keys %{ $gen_fields_key }; my $gen_files = $self->{spec}{$file_field}{gen_files}; my $q = $self->{query}; my %out; my ($w,$h) = ($meta->{width},$meta->{height}); for my $gen_file (@gen_files) { my $gen_tmp_filename; # tranform as needed my $gen_file_key = $self->{spec}{$file_field}{gen_files}{$gen_file}; # Recommended code ref API if (ref $gen_file_key eq 'CODE') { # It needed any params, they should already have been provided via closure. $gen_tmp_filename = $gen_file_key->($self,$tmp_filename); } # Old, yucky hashref API elsif (ref $gen_file_key eq 'HASH') { my $meth = $gen_file_key->{transform_method}; $gen_tmp_filename = $meth->( $self, $tmp_filename, $gen_file_key->{params}, ); } else { croak "$gen_file for $file_field was not a hashref or code ref. Check spec syntax."; } # inherit mime-type and extension from parent # but merge in updated details for this file my $meta_from_gen_file = $self->extract_meta($gen_tmp_filename,$gen_file); $meta_from_gen_file ||= {}; my %t_info = (%$meta, gen_from_id => $gen_from_id, %$meta_from_gen_file); # Try to get image dimensions (will fail safely for non-images) #($t_info{width}, $t_info{height}) = imgsize($gen_tmp_filename); # Insert my $id = $self->store_meta($gen_file, \%t_info ); # Add to output hash $out{$gen_file.'_id'} = $id; $self->store_file($gen_file,$id,$t_info{extension},$gen_tmp_filename); } return %out; } =head2 delete_upload() $u->delete_upload($upload_id); This method is used to delete the meta data and file associated with an upload. Usually it's more convenient to use C than to call this method directly. This method does not delete generated files for this upload. =cut sub delete_upload { my $self = shift; my ($id) = @_; $self->delete_file($id); $self->delete_meta($id); } =head2 delete_gen_files() $self->delete_gen_files($id); Delete the generated files for a given file ID, from the file system and the database =cut sub delete_gen_files { validate_pos(@_,1,1); my ($self,$id) = @_; my $dbh = $self->{dbh}; my $map = $self->{up_table_map}; my $gen_file_ids_aref = $dbh->selectcol_arrayref( "SELECT $map->{upload_id} FROM ".$self->{up_table}. " WHERE $map->{gen_from_id} = ?",{},$id) || []; for my $gen_file_id (@$gen_file_ids_aref) { $self->delete_file($gen_file_id); $self->delete_meta($gen_file_id); } } =head1 Meta-data Methods =head2 extract_meta() $meta = $self->extract_meta($tmp_filename,$file_name,$uploaded_mt); This method extracts and returns the meta data about a file and returns it. Input: - Path to file to extract meta data from - the name of the file (as sent through the file upload file) - The mime-type of the file, as supplied by the browser Returns: a hash reference of meta data, following this example: { mime_type => 'image/gif', extension => '.gif', bytes => 60234, file_name => 'happy.txt', # only for images width => 50, height => 50, } =cut sub extract_meta { validate_pos(@_,1,1,1,0); my $self = shift; my $tmp_filename = shift; my $file_name = shift; my $uploaded_mt = shift || ''; # Determine and set the appropriate file system parsing routines for the # uploaded path name based upon the HTTP client header information. use HTTP::BrowserDetect; my $client_os = $^O; my $browser = HTTP::BrowserDetect->new; $client_os = 'MSWin32' if $browser->windows; $client_os = 'MacOS' if $browser->mac; $client_os = 'Unix' if $browser->macosx; require File::Basename; File::Basename::fileparse_set_fstype($client_os); $file_name = File::Basename::fileparse($file_name,[]); require File::MMagic; my $mm = File::MMagic->new; # If the uploaded mime_type was not provided calculate one from the file magic number # if that does not exist, fall back on the file name my $fm_mt = $mm->checktype_magic($tmp_filename); $fm_mt = $mm->checktype_filename($tmp_filename) if (not defined $fm_mt or not length $fm_mt) ; my $mt = ($uploaded_mt || $fm_mt); assert($mt,'found mime type'); use MIME::Types; my $mimetypes = MIME::Types->new; my MIME::Type $t = $mimetypes->type($mt); my @mt_exts = $t ? $t->extensions : undef; my $ext; # figure out an extension my ($uploaded_ext) = ($file_name =~ m/\.([\w\d]*)?$/); # If there is at least one MIME-type found if ($mt_exts[0]) { # If the upload extension is one recognized by MIME::Type, use it. if ((defined $uploaded_ext) and (grep {/^$uploaded_ext$/} @mt_exts)) { $ext = $uploaded_ext; } # otherwise, use one from MIME::Type, just to be safe else { $ext = $mt_exts[0]; } } else { # If is a provided extension but no MIME::Type extension, use that. # It's possible that there no extension uploaded or found) $ext = $uploaded_ext; } if ($ext) { $ext = ".$ext" if $ext; } else { croak "no extension found for file name: $file_name"; } # Now get the image dimensions if it's an image my ($width,$height) = imgsize($tmp_filename); return { file_name => $file_name, mime_type => $mt, extension => $ext, bytes => (stat ($tmp_filename))[7], # only for images width => $width, height => $height, }; } =head2 store_meta() my $id = $self->store_meta($file_field,$meta); This function is used to store the meta data of a file upload. Input: - file field name - A hashref of key/value pairs to be stored. Only the key names defined by the C in C will be used. Other values in the hash will be ignored. - Optionally, an upload ID can be passed, causing an 'Update' to happen instead of an 'Insert' Output: - The id of the file stored. The id is generated by store_meta(). =cut sub store_meta { validate_pos(@_,1,1,1,0); my $self = shift; # Right now we don't use the the file field name # It seems like a good idea to have in case you want to sub-class it, though. my $file_field = shift; my $href = shift; my $id = shift; my $DBH = $self->{dbh}; require SQL::Abstract; my $sql = SQL::Abstract->new; my $map = $self->{up_table_map}; my %copy = %$href; my $is_update = 1 if $id; if (!$is_update && $self->{db_driver} eq 'Pg') { $id = $DBH->selectrow_array("SELECT NEXTVAL('".$self->{up_seq}."')"); $copy{$map->{upload_id} } = $id; } my @orig_keys = keys %copy; for (@orig_keys) { if (exists $map->{$_}) { # We're done if the names are the same next if ($_ eq $map->{$_}); # Replace each key name with the mapped name $copy{ $map->{$_} } = $copy{$_}; } # The original field is now duplicated in the hash or unknown. # delete in either case. delete $copy{$_}; } my ($stmt,@bind); if ($is_update) { ($stmt,@bind) = $sql->update($self->{up_table},\%copy, { $map->{upload_id} => $id }); } else { ($stmt,@bind) = $sql->insert($self->{up_table},\%copy); } $DBH->do($stmt,{},@bind); if (!$is_update && $self->{db_driver} eq 'mysql') { $id = $DBH->{'mysql_insertid'}; } if (!$is_update && $self->{db_driver} eq 'SQLite') { $id = $DBH->func('last_insert_rowid') } return $id; } =head2 delete_meta() my $dbi_rv = $self->delete_meta($id); Deletes the meta data for a file and returns the DBI return value for this operation. =cut sub delete_meta { validate_pos(@_,1,1); my $self = shift; my $id = shift; my $DBH = $self->{dbh}; my $map = $self->{up_table_map}; return $DBH->do("DELETE from ".$self->{up_table}." WHERE $map->{upload_id} = $id"); } =head2 transform_meta() my %meta_to_display = $u->transform_meta( meta => $meta_from_db, prefix => 'my_field', prevent_browser_caching => 0, fields => [qw/id url width height/], ); Prepares meta data from the database for display. Input: - meta: A hashref, as might be returned from "SELECT * FROM uploads WHERE upload_id = ?" - prefix: the resulting hashref keys will be prefixed with this, adding an underscore as well. - prevent_browse_caching: If set to true, a random query string will be added, preventing browsings from caching the image. This is very useful when displaying an image an 'update' page. Defaults to true. - fields: An arrayef of fields to format. The values here must be keys in the C. Two field names are special. 'C is used to denote the upload_id. C combines several fields into a URL to link to the upload. Output: - A formatted hash. See L for example output. =cut sub transform_meta { my $self = shift; my %p = validate(@_, { meta => { type => HASHREF }, prefix => { type => SCALAR }, prevent_browser_caching => { default => 1 }, fields => { type => ARRAYREF , default => [qw/id url width height/], }, }); # return undef unless (ref $p{meta} eq 'HASH'); my $map = $self->{up_table_map}; my %result; my $qs; if ($p{prevent_browser_caching}) { # a random number to defeat image caching. We may want to change this later. my $rand = (int rand 100); $qs = "?$rand"; } my %fields = map { $_ => 1 } @{ $p{fields} }; if ($fields{url}) { $result{$p{prefix}.'_url'} = $self->{updir_url}.'/'. $self->build_loc( $p{meta}{ $map->{upload_id} } ,$p{meta}{ $map->{extension} }) .$qs ; delete $fields{url}; } if (exists $fields{id}) { $result{$p{prefix}.'_id'} = $p{meta}->{ $map->{upload_id} }; delete $fields{id}; } for my $k (keys %fields) { my $v = $p{meta}->{ $map->{$k} }; $result{$p{prefix}.'_'.$k} = $v if defined $v; } return %result; } =head2 get_meta() my $meta_href = $self->get_meta($id); Returns a hashref of data stored in the uploads database table for the requested file id. =cut sub get_meta { validate_pos(@_,1,1); my ($self,$id) = @_; my $map = $self->{up_table_map}; return $self->{dbh}->selectrow_hashref(" SELECT * FROM $self->{up_table} WHERE $map->{upload_id} = ?",{},$id); } =head1 File Methods =head2 store_file() $self->store_file($file_field,$tmp_file,$id,$ext); Stores an upload file or dies if there is an error. Input: - file field name - path to tmp file for uploaded image - file id, as generated by C - file extension, as discovered by L Output: none =cut sub store_file { validate_pos(@_,1,1,1,1,1); my $self = shift; my ($file_field,$id,$ext,$tmp_file) = @_; assert($ext, 'have extension'); assert($id,'have id'); assert(-f $tmp_file,'tmp file exists'); assert(-d $self->{updir_path},'updir_path is a directory'); assert(-w $self->{updir_path},'updir_path is writeable'); require File::Copy; import File::Copy; copy($tmp_file, File::Spec->catdir($self->{updir_path},$self->build_loc($id,$ext)) ) || croak "Unexpected error occured when uploading the image: $!"; } =head2 delete_file() $self->delete_file($id); Call from within C, this routine deletes the actual file. Dont' delete the the meta data first, you may need it build the path name of the file to delete. =cut sub delete_file { validate_pos(@_,1,1); my $self = shift; my $id = shift; my $map = $self->{up_table_map}; my $dbh = $self->{dbh}; my $ext = $dbh->selectrow_array(" SELECT $map->{extension} FROM $self->{up_table} WHERE $map->{upload_id} = ?",{},$id); $ext || croak "found no extension in meta data for ID $id. Deleting file failed."; my $file = $self->{updir_path}.'/'.$self->build_loc($id,$ext); if (-e $file) { unlink $file || croak "couldn't delete upload file: $file: $!"; } else { warn "file to delete not found: $file"; } } =head1 Utility Methods =head2 build_loc() my $up_loc = $self->build_loc($id,$ext); Builds a path to access a single upload, relative to C. This is used to both file-system and URL access. Also see the C option to C, which affects it's behavior. =cut sub build_loc { validate_pos(@_,1,1,0); my ($self,$id,$ext) = @_; my $scheme = $self->{file_scheme}; my $loc; if ($scheme eq 'simple') { $loc = "$id$ext"; } elsif ($scheme eq 'md5') { require Digest::MD5; import Digest::MD5 qw/md5_hex/; my $md5_path = md5_hex($id); $md5_path =~ s|^(.)(.)(.).*|$1/$2/$3|; my $full_path = $self->{updir_path}.'/'.$md5_path; unless (-e $full_path) { mkpath($full_path); } $loc = File::Spec->catdir($md5_path,"$id$ext"); } } =head2 upload_field_names() # As a class method (@file_field_names) = CGI::Uploader->upload_field_names($q); # As an object method (@file_field_names) = $u->upload_field_names(); Returns the names of all form fields which contain file uploads. Empty file upload fields may be excluded. This can be useful for auto-generating a C. Input: - A query object is required as input only when called as a class method. Output: - an array of the file upload field names. =cut sub upload_field_names { my $self = shift; my $q = shift || $self->{query}; my @file_field_names; if ( $q->isa('CGI::Simple') ) { my @list_of_files = $q->upload; my @all_field_names = $q->param(); for my $field (@all_field_names) { my $potential_file_name = $q->param($field); push @file_field_names, $field , if grep {m/^$potential_file_name/} @list_of_files; } } elsif ($q->isa('Apache::Request') ) { @file_field_names = map { $_->name } @{ $q->upload() }; } # default to CGI.pm behavior else { my @all_field_names = $q->param(); for my $field (@all_field_names) { push @file_field_names, $field , if $q->upload($field); } } return @file_field_names; } =head2 spec_names() $spec_names = $u->spec_names('file_field'): With no arguments, returns an array of all the upload names defined in the spec, including any generated file names. With one argument, a file field from the spec, can also be provided. It then returns that name as well as the names of any related generated files. =cut sub spec_names { my $self = shift; my $spec_key = shift; my $all_keys = $self->{spec}; # only use $spec_key if it was passed in my @primary_spec_keys_to_use = (defined $spec_key) ? $spec_key : keys %$all_keys; my @gen_files = @primary_spec_keys_to_use, map { keys %{ $all_keys->{$_}{gen_files} } } @primary_spec_keys_to_use; } 1; __END__ =head1 Contributing Patches, questions and feedback are welcome. I maintain CGI::Uploader using git. The public repo is here: https://github.com/markstos/CGI--Uploader =head1 Author Mark Stosberg =head1 Thanks A special thanks to David Manura for his detailed and persistent feedback in the early days, when the documentation was wild and rough. Barbie, for the first patch. =head1 License This program is free software; you can redistribute it and/or modify it under the terms as Perl itself. CGI-Uploader-2.18/lib/CGI/Uploader/0000755000175000017500000000000011522150471015206 5ustar markmarkCGI-Uploader-2.18/lib/CGI/Uploader/Transform/0000755000175000017500000000000011522150471017161 5ustar markmarkCGI-Uploader-2.18/lib/CGI/Uploader/Transform/ImageMagick.pm0000644000175000017500000001345611522150073021664 0ustar markmarkpackage CGI::Uploader::Transform::ImageMagick; use base 'Exporter'; use File::Temp 'tempfile'; use Params::Validate ':all'; use Carp::Assert; our $VERSION = 2.18; our @EXPORT = qw(&gen_thumb); =head2 gen_thumb() use CGI::Uploader::Transform::ImageMagick; As a class method: ($thumb_tmp_filename) = CGI::Uploader::Transform::ImageMagick->gen_thumb({ filename => $orig_filename, w => $width, h => $height }); Within a CGI::Uploader C: gen_files => { my_thumb => gen_thumb({ w => $width, h => $height }), } Looking for a different syntax? See L This function creates a copy of given image file and resizes the copy to the provided width and height. C can be called as object or class method. As a class method, there there is no need to call C before calling this method. L is used as the first choice image service module. L is tried next. Input: filename - filename of source image w - max width of thumbnail h - max height of thumbnail One or both of C or C is required. Output: - filename of generated tmp file for the thumbnail - the initialized image generation object. (You generally shouldn't need this) =cut sub gen_thumb { # If the first arg is an object, we have really work to do right now my $first_arg = $_[0]; use Scalar::Util (qw/blessed/); if ((blessed $first_arg) or (eval {$first_arg->can('gen_thumb')})) { return _really_gen_thumb(@_); } # Otherwise, just generate a closure pass back a code ref for later use else { # require a single hashref as input my ($args_href) = validate_pos(@_, { type => HASHREF }); return sub { my $self = shift; my $filename = shift; _really_gen_thumb($self, { filename => $filename, %$args_href, }); } } } sub _really_gen_thumb { my $self = shift || die "gen_thumb needs object"; my (%p,$orig_filename,$params); # If we have the new hashref API if (ref $_[0] eq 'HASH') { %p = validate(@_,{ filename => { type => SCALAR }, w => { type => SCALAR | UNDEF, regex => qr/^\d*$/, optional => 1, }, h => { type => SCALAR | UNDEF, regex => qr/^\d*$/, optional => 1 }, }); $orig_filename = $p{filename}; } # we have the old ugly style API else { ($orig_filename, $params) = validate_pos(@_,1,{ type => ARRAYREF }); # validate handles a hash or hashref transparently %p = validate(@$params,{ w => { type => SCALAR | UNDEF, regex => qr/^\d*$/, optional => 1, }, h => { type => SCALAR | UNDEF, regex => qr/^\d*$/, optional => 1 }, }); } die "must supply 'w' or 'h'" unless (defined $p{w} or defined $p{h}); # Having both Graphics::Magick and Image::Magick loaded at the same time # can cause very strange problems, so we take care to avoid that # First see if we have already loaded Graphics::Magick or Image::Magick # If so, just use whichever one is already loaded. my $magick_module; if (exists $INC{'Graphics/Magick.pm'}) { $magick_module = 'Graphics::Magick'; } elsif (exists $INC{'Image/Magick.pm'}) { $magick_module = 'Image::Magick'; } # If neither are already loaded, try loading either one. elsif ( _load_magick_module('Graphics::Magick') ) { $magick_module = 'Graphics::Magick'; } elsif ( _load_magick_module('Image::Magick') ) { $magick_module = 'Image::Magick'; } else { die "No graphics module found for image resizing. Install Graphics::Magick or Image::Magick: $@ " } my ($thumb_tmp_fh, $thumb_tmp_filename) = tempfile('CGIuploaderXXXXX', UNLINK => 1, DIR => $self->{'temp_dir'}); binmode($thumb_tmp_fh); my $img = $magick_module->new(); my $err; eval { $err = $img->Read(filename=>$orig_filename); die "Error while reading $orig_filename: $err" if $err; my ($target_w,$target_h) = _calc_target_size($img,$p{w},$p{h}); $err = $img->Resize($target_w.'x'.$target_h); die "Error while resizing $orig_filename: $err" if $err; $err = $img->Write($thumb_tmp_filename); die "Error while writing $orig_filename: $err" if $err; }; if ($@) { warn $@; my $code; # codes > 400 are fatal die $err if ((($code) = $err =~ /(\d+)/) and ($code > 400)); } assert ($thumb_tmp_filename, 'thumbnail tmp file created'); return wantarray ? ($thumb_tmp_filename, $img ) : $thumb_tmp_filename; } # Calculate the target with height # # my ($target_w,$target_h) = _calc_target_size($img,$p{w},$p{h}) # # Input: # # - Magick object, pre-opened with the original file # - provided width # - provided height sub _calc_target_size { my ($img,$w,$h) = @_; my $target_h = $h; my $target_w = $w; my ($orig_w,$orig_h) = $img->Get('width','height'); $target_h = sprintf("%.1d", ($orig_h * $target_w) / $orig_w) unless $target_h; $target_w = sprintf("%.1d", ($orig_w * $target_h) / $orig_h) unless $target_w; return ($target_w,$target_h); } # load Graphics::Magick or Image::Magick if one is not already loaded. sub _load_magick_module { my $module_name = shift; return eval "require $module_name"; } =head2 BACKWARDS COMPATIBILITY These older, more awkward syntaxes are still supported: As a class method: ($thumb_tmp_filename) = CGI::Uploader::Transform::ImageMagick->gen_thumb( $orig_filename, [ w => $width, h => $height ] ); In a C C: 'my_img_field_name' => { transform_method => \&gen_thumb, params => [ w => 100, h => 100 ], } 1; CGI-Uploader-2.18/lib/CGI/Uploader/Cookbook.pod0000644000175000017500000003133211522141350017456 0ustar markmark =head1 NAME CGI::Uploader::Cookbook - Examples of CGI::Uploader usage =head1 Description C is a tutorial that accompanies the B distribution. It shows example syntax for common uses. C module is designed to help with the task of managing files uploaded through a CGI application. The files are stored on the file system, and the file attributes stored in a SQL database. =head1 Introduction to CGI::Uploader =head2 A Little History The release of this module represents a culmination of seven years of experience managing file uploads as a professional website developer for Summersault, LLC (L). Over that time I noticed patterns that were re-usable from project to project. I went through several versions and rewrites of modules that attempted to be 'generic' and not need modification when the next project came along. With CGI::Uploader, I believe I finally have a solution that I will continue to be happy with and I think others will be find generally useful. Enjoy! =head2 Freedom of Choice I endeavored to make CGI::Uploader to work within a variety of system designs. It offers you freedom choice in the following areas: =over =item * Database Choice MySQL and Postgres are supported directly. The SQL used is very simple-- support for additional databases should be trivial. =item * Choice of Query Provider The query object used may provided by C, C or C. Another source could be used by overriding the C method. =item * File Storage Schemes for Large and Small Projects For small projects, all uploads can be stored in a single directory. For large projects, we provide the C file scheme, which should scale well to millions of images, without burdening any single directory with storing too many of them. =item * Choice of Data Display Because the meta data is stored in a straightforward SQL database table, you can retrieve your data and display in any number of custom ways. Several functions are also built in to help with common display tasks. The C method is used to construct the file system or URL path of an image, given it's ID and extension. C provides an easy way to get the meta data of an upload by relating it to a foreign key in another table. Finally, C is a basic function which transforms a hashref of data from the database into a format more useful for display, producing a hash that looks like this: { my_custom_prefix_id => 523, my_custom_prefix_url => 'http://localhost/images/uploads/523.pdf', my_custom_prefix_width => 23, my_custom_prefix_height => 46, } =item * Image Processor While C works with all types of file uploads, it contains a number of features to help with common tasks associated with image uploads. C is the preferred image processing module for to use when creating the thumbnails. Support for C is in progress. C supports many fewer formats, but also has much fewer dependencies to get installed than C does. Another providers could be used by extending or overriding the C method. =back =head2 Just Three Essential Methods to Learn A goal of is to provide a high-level interface to make managing file uploads easy. Only three methods are needed to manage all the functions needed to store, update, delete and view the uploads attached to some database entity. Those methods are C, C and C. =head2 More methods when you need them When your needs before more complex, you can call the lower-level functions in C to meet your needs. Most functions use file names to access file uploads, so it's easy to use the module to manipulate files from other sources than the browser upload field. For example, the C method is general purpose thumbnail creating routine. =head1 Browse, Read, Edit, Add, Delete (BREAD) Example Application The following sections will provide a walk through of a simple application using CGI::Uploader. This is intended to provide the picture of how this module can be used. Some details have been glossed over. For a complete, working example application, please see the C directory of the distribution. Before C can be useful, some setup needs to be done. You need some database tables to store the information in. =head2 Example Database For these examples, we'll set up some tables to manage photos of friends. Here is the SQL to create such tables with Postgres: -- Note the Postgres specific syntax here CREATE SEQUENCE upload_id_seq; CREATE TABLE uploads ( upload_id int primary key not null default nextval('upload_id_seq'), mime_type character varying(64), extension character varying(8), -- file extension width integer, height integer, gen_from_id integer ); CREATE SEQUENCE friend_id_seq; CREATE TABLE address_book ( friend_id int primary key NOT NULL DEFAULT nextval('friend_id_seq'), full_name varchar(64), -- these two reference uploads('upload_id'), photo_id int, photo_thumbnail_id int ); (I is also supported. Check in the distribution for sample SQL 'Create' scripts for both I and I databases). =head2 Object Creation You can create one C object and use it for adding, updating, viewing and deleting uploads. So don't despair that it has a few required parameters-- you only need to type them once! :) use CGI::Uploader::Transform::ImageMagick; my $u = CGI::Uploader->new( spec => { photo => { gen_files => { photo_thumbnail => gen_thumb({ w => 100, h => 100}), } } } updir_url => 'http://localhost/uploads', updir_path => '/home/friends/www/uploads', dbh => $dbh, ); =head1 Adding a Database Record and Related Uploads Before we can do anything else with the uploads, we need to get some added into the system. C is designed to make this happening easily as part of the normal process of adding a normal database record. In this case, we'll be adding a friend. =head2 Example 'Add Form' Here's the form used to add a friend. It includes fields for the friend's name, and a photo of them.
Friend Name:
Image:
Notice that the 'enctype' is important for file uploads to work. Notice we have a text field for a 'full_name' and a file upload field named 'photo'. =head2 Processing the Add Form AS a first step for processing the 'add form', I recommend validating the form with L. It includes several routines just to validate file uploads. However, it's not necessary to validate the form. # CGI::Simple provides a CGI.pm-like interface with much better performance use CGI::Simple; my $q = CGI::Simple->new(); my $form = $q->Vars; my $friend = $u->store_uploads($form); # Now the $friend hash been transformed so it can easily inserted # It now looks like this: # { # full_name => 'M. Lewis', # photo_id => 3, # photo_thumbnail_id => 4, # } # I like to use SQL::Interp for easy inserts. # See DBIx::Simple for an even more friendly wrapper. use SQL::Interp 'sql_interp'; $dbh->do(sql_interp "INSERT INTO address_book",$friend); =head2 Database Result of Adding Here's what ended up in the database: address_book table: friend_id | full_name | photo_id | photo_thumbnail_id ----------------------------------------------------- 2 | M. Lewis | 3 | 4 uploads table: upload_id | mime_type | extension | width | height | gen_from_id -------------------------------------------------------------------- 3 | image/png | .png | 200 | 400 | 4 | image/png | .png | 50 | 100 | 3 The files are stored on the file system. '4.png' was generated on the server a thumbnail of 3.png. /home/friends/www/uploads/3.png /home/friends/www/uploads/4.png =head1 Displaying & Linking to Uploads You don't strictly need this module to display the uploaded image. You could construct your own database queries and URLs instead. However, the C method is provided to simplify things for you. Continuing with the example above, we would use this code to generate the details we need to display and link to the photo and thumbnail: my $href = $u->fk_meta( table => 'address_book', where => { friend_id => 2 }, prefixes => [qw/photo photo_thumbnail/], ); That will fetch the details of the photo and thumbnail associated with the friend who is an ID of "2". The resulting hashref will look something like this: { photo_id => 3, photo_url =>'http://localhost/uploads/3.png?23', photo_width => 200, photo_height => 400', photo_thumbnail_id => 4, photo_thumbnail_url =>'http://localhost/uploads/4.png?23', photo_thumbnail_width => 50, photo_thumbnail_height => 200', } This hashref can often be passed directly to a templating system such as L for display. You may be wondering about the query strings on the URLS. These are random numbers to defeat browser image caching, which is very useful on "edit" forms. This behavior may change or become optional in a future release. =head1 Displaying an Update Form So now we've added 'M. Lewis' to our friend database and displayed his photo on the web. M. Lewis turned out not to be happy about this. He reports that the photo used was not his 'good side' and has sent a 'better' photo to use. So now we need to have a form to update the photo from. The form to update the upload will be a lot like the 'add form'. Additionally, it's nice to display a link to current upload on the form. This can be done using C, as demonstrated above. Our Update Form might look like this if we are using L for display:

Friend Name:

Current Image
Delete Image?

Image:

=head2 Processing an Update Form Processing an update form is the most complicated part of application. From this form it's possible to add, update and delete uploads To process the update form, we'll first delete any uploads that the user has requested to remove. Next, add and update any other uploads as need. my $friend = $q->Vars; my @fk_names = $u->delete_checked_uploads; map { $friend->{$_} = undef } @fk_names; delete $friend->{photo_delete}; $friend = $u->store_uploads($friend); Although the call to C looks the same as it did for adding a record, it works a little different now. Notice we passed a photo_id through the form above. Because this is present, that record will be updated instead of creating a new one. =head1 Recipe Idea: Put an existing directory of photos on line You have an existing directory full of JIGS that you want to put on-line as a photo gallery, with medium and small versions created of all the images. C is versatile enough to help in this situation as well. Your spec might look like this: large_jpeg => [ { name => 'medium', w => 500, }, { name => 'small', w => 250, ], From there, read in all the file names and store all the files, with the smaller versions being created automatically for you along the way. for my $jpeg (<*.jpg>) { my %entity_upload_extra = $self->store_upload( file_field => 'large_jpeg', src_file => $jpeg, uploaded_mt => 'image/jpeg', file_name => $jpeg, ); } Now you may want to display a page containing all of the smallest thumbnails. If these IDs had been stored in another table, we could use fk_meta() to get all of the small thumbnails. In this case, it is still possible to get a reasonable result by selecting images based on their size. [TODO: example code for this needs to be written. ] =head1 Recipe Idea: Handling anonymous image uploads It is also possible with CGI::Uploader to have many "anynonmous" uploads associated with another entity in the database. [ TODO: And the documentation for how to that still needs to be written. :) ] =head1 See Also L =head1 Author Mark Stosberg =cut CGI-Uploader-2.18/Changes0000644000175000017500000002551311522150351013561 0ustar markmarkRevision history for Perl extension CGI::Uploader. 2.18 Feb 1, 2011 [INTERNAL] - We now call "local $CGI::DISABLE_UPLOADS=0" just before uploading with CGI.pm or CGI::Simple. For improved security, set the related variable globally to "1" to disable file uploads by default, and then re-enable them any other places where you need uploading enabled. Read about $DISABLE_UPLOADS in CGI.pm or CGI::Simple for details. (Thanks to Brian Meeker for help with this patch.) - Now require Perl 5.8 as the minimum version. - Address warning about $fm_mt being undefined. 2.17 Thu Apr 2 11:43:50 EDT 2009 [BUG FIXES] - Small but fatal typo fix from 2.16 release cycle. 2.16 Thu Apr 2 11:36:40 EDT 2009 [BUG FIXES] - Using 'transform_method' to tranform an upload in place was broken. - Now use File::Spec instead of hardcoding "/" as a path separator. (Ron Savage) - Use binmode() on the right file handle (Ron Savage) - upload_id was hardcoded in one place instead of using up_table_map (Ron Savage) [DOCUMENTATION] - Quit recommending SQL::Abstract in the Cookbook (but we use it internally) [INTERNAL] - Mark "Image::Size" as a requirement, if only to get tests to stop failing. It's only really required if you use the Image::Magick transformations. 2.15 Sun Jul 15 07:21:24 EDT 2007 - no functionality changes [INTERNAL] - improved importing code style. - Clarify docs regarding file_scheme vs. file_name (Jaldhar) 2.14 Thu May 24 13:19:27 EDT 2007 [BUG FIXES] - Avoid SQL error when two column names are the same by giving explicit table name. 2.13 Mon Apr 9 22:39:54 EDT 2007 [BUG FIXES] - Better Mac OS X detection (Jeff MacDonald) - gen_thumb() now works if Image::Magick or Graphics::Magick is not already loaded. (Thanks to bug report by Jeff MacDonald, RT#20775). 2.12 Thu Feb 15 17:43:20 EST 2007 [ENHANCEMENTS] - Explicitly call File::Temp::cleanup(). This reduces the amount of disk space and file handles used. - A new 'temp_dir' option has been added to allow to you set your own temporary directory. (Jeff MacDonald) 2.11 Mon Dec 19 20:18:00 EST 2005 [BUG FIXES] - There were was confusion in the 2.1 release as to whether the new API for gen_thumb() took a hash or hashref as input. The code, tests and docs have all been updated to agree: It's a hashref. Thanks to bignose, who wrestled this one. 2.1 Sun Dec 18 21:39:23 EST 2005 [ENHANCEMENTS] - Further simplified necessary spec API, while maintaining backwards compatibility. Specifying a transformation method for a generated file can now by this simple: gen_files => { photo_thumbnail => gen_thumb({ w => 100, h => 100}), } 2.0 Sat Dec 17 23:12:35 EST 2005 [ENHANCEMENTS] - Previously the extension and MIME type were inherited by generated files. Now the metadata for generated files is extracted directly from them. This should be useful if you want to create thumbnails in a different image format than the large images. - A cleaner and simpler API for calling gen_thumb() and other potential transform_methods has been introduced. The new syntax looks like this: transform_method => gen_thumb({ w => 100, h => 100 }), The old syntax is still supported. - "gen_thumb()" can now return the Image/Graphics::Magick object as a second argument. This may not be useful outside of the test suite... [BUG FIXES] - Image::Magick is no longer required to install CGI::Uploader, just recommended. - If an uploaded was updated and had its MIME type changed in the process, the old file was left on the file system. Fixed. - If 'up_table_map' was used to modify the name of the extension field, then transform_meta() would return empty values for the extensions. Fixed. [INTERNALS] - Migrated Makefile.PL to use Module::Install. This allows me to keep the hairy Makefile.PL stuff I have, but easily add 'no_index' and 'recommends' metadata. - test suite clean up. - new required modules: Scalar::Util and HTTP::Request::Common 1.2 Thu Dec 15 22:35:39 EST 2005 [BUG FIXES] - Fixed bug in store_uploads() from improper hash usage. [INTERNALS] - Fixed some typos in Makefile.PL requirements - Made test suite use SQLite by default for easier testing. 1.1 Wed Dec 14 21:23:56 EST 2005 [INTERNALS] - Now require at least Params::Validate 0.77 (RT#13728) - ..and require at least File::Temp 0.14, for a better chance of using a real temporary directory. 1.1_1 Mon Apr 4 07:52:01 EST 2005 [THINGS THAT MIGHT BREAK YOUR CODE] - 'file_name' is now required in the data model. You can simply add it before upgrading. Something like this should work: ALTER TABLE your_table_name ADD COLUMN file_name VARCHAR(255); Of course, you can name the column something else with the up_table_map. [ENHANCEMENTS] - extract_meta() now also returns the original filename with the 'file_name' key. - PostgreSQL via ODBC is now supported (William McKee) [BUG FIXES] - Fixed RT#12051, an XSS issue in an example application. (William McKee). [INTERNALS] - Clean up some test warnings (Denis McKeon) - Better diagnostics in ImageMagick.pm (William McKee) 1.00 - No code changes, I'm just declaring it stable. - Mention availability via darcs 0.80_02 08/19/04 - Added missing ImageMagick.pm (Barbie) - Made t/up_table_map.t more portable (Barbie) 0.80_01 [RELEASE NOTES] I changed the API again. The code has been refactored to remove all image-specific code from the main package. In it's place a more general "transform_method" option has been added. With this, you can specify any arbitrary transformation you want to make to a file. You might choose to decrypt a file, compress it, append to it, or otherwise alter it. The thumbnailing code still exists, but has been moved to CGI::Uploader::Transform::ImageMagick::gen_thumb(). However, most of the examples and tests still do rely on "gen_thumb()" for examples, so test failures will occur if Image::Magick is not installed for now. I'd like some help to streamline this. Along the way, I removed the regular expression support to simplify the refactoring. It may well come back. Beyond these changes, things are pretty much the same. Let me know if you have any feedback on the API before this turns into a stable 1.0 release. Mark Stosberg mark@summersault.com 0.76.02 [ENHANCEMENTS] - Added image gallery recipe to cookbook - Added README to examples/friends_photos 0.76_01 Sun Apr 25, 2004 [BUG FIXES] - Fixed syntax errors in Cookbook SQL example - Fixed bug where default query object wasn't loading correctly - Fixed documtention of fk_meta() to match current interface. - Fixed bug in t/up_table_map.t test [ENHANCEMENTS] - Added example application to distribution 0.75_02 - Refactored delete_upload() to be simpler and more intuitive. 0.75_01 Added support for specifying fields to process via regular expressions. - Improved Cookbook documentation. 0.70_02 Wed Apr 21, 2004 - Removed custom_meta(). This problem space is now addressed by allowing meta data to be passed to store_uploads(). Also, you could override extract_meta() to add more functionality there. - Added support for storing files based on a MD5 sum of the files ID. This allows the file storage to scale well for millions of uploads. See the docs for 'file_scheme' for detaills. (Thanks to Randal Schwartz for the suggestion). - Added option to specify only a max width or max height for thumbnails. - Refactored several interfaces to use named parameters. - Added 'downsize' option to spec, allowing downsizing of primary images. 0.70_01 - Added to binmode() calls to file handles, to possibly help Windows. - Added support for uploading via CGI::Simple - Added experimental support for uploading via Apache::Request - Added Cookbook documentation - Added 'thumbnail_of_id' column to meta data table. - Added delete_thumbs() method - Started to do real 'updates' rather than delete/re-inserts - Cleaned up prequisites in Makefile.PL - Fixed bug and added test for proper thumbnail resizing - More API refactors 0.63_01 - Removed some un-needed mentions of Data::FormValidator from tests - added test to verify thumbnail size - refactored resize code into gen_thumb(). This will make it easier to support other resize modules besides Image::Magick. - Added Image::Size as a dependency. It's a fast tool for size checking which does not depend on a graphics module being installed. - Initial support for resizing with GD as a backup. It needs tested. 0.62_01 - Added File::Temp to Makefile.PL. - Refactored to remove store_thumb(). This should help eventually support other graphics modules besides Image::Magick 0.61_02 - Minor POD cleanups 0.61_01 - Added custom_meta() method for more flexible meta data handled - clarified code and extended documentation - exposed 'build_loc' function, which may be useful as a utility function, or for a sub-class. - custom fields are now returned with meta_hashref() 0.60_02 - Added up_table_map test and fixed some related code. 0.60_01 - Added 'up_table_map' configuration option, allowing for custom column names. - Documentation for several functions added. - Began refactoring to make support for Apache::Request easier. 0.50_03 Mon Mar 22, 2004 - possible "binmode" test fix for Windows platforms. 0.50_02 Sun Mar 21, 2004 - Removed dependence on Image::Size - Documentation clarifications (David Manura) 0.50_01 Web Feb 11, 2004 - Removed dependence on Data::FormValidator 0.40_01 Sun Feb 8, 2004 - Extensive documentation updates, thanks to feedback from David Manura. 0.30_01 Fri Feb 6, 2004 - The API was largely re-worked, with several methods renamed and a few added. No backwards compatibility can be expected. 0.10 [THINGS THAT MIGHT BREAK YOUR CODE] - create_img_tmpl_vars() has been replaced with a more generic create_tmpl_vars(). It should still work the same for images, and better for non-images - install_uploads() Now returns a hash ref based on the valid hash, with appropriate additions and deletions already made. - The interface for delete_upload() has changed to accomodate deleting based on directly providing a upload ID. 0.02 Sun May 18 2003 - initial public release 0.01 Sat May 17 16:15:05 2003 - original version; created by h2xs 1.22 with options -b 5.5.0 -XAn CGI::Uploader CGI-Uploader-2.18/t/0000755000175000017500000000000011522150471012526 5ustar markmarkCGI-Uploader-2.18/t/cgi-simple.t0000644000175000017500000001361511522141350014746 0ustar markmark######################### # This test is basically a copy of t/basic.t # with CGI::Simple substituted for CGI.pm use Test::More; Test::More->builder->no_ending(1); use Carp::Assert; use Config; use Data::Dumper; use DBI; use Test::DatabaseRow; use HTTP::Request::Common; use lib 't/lib'; use CGI::Uploader::Test; # provides setup() read_file(), etc use strict; $| = 1; if (! $Config{d_fork} ) { plan skip_all => "fork not available on this platform"; } else { eval { require CGI::Simple; import CGI::Simple qw(-upload); }; if($@) { plan skip_all => 'CGI::Simple not available' } else { plan skip_all => 'CGI::Simple should work, but having these tests for it work is pending a bug fix: http://rt.cpan.org/NoAuth/Bug.html?id=14838'; #plan tests => 23; } } my ($DBH,$drv) = setup(); my $req = &HTTP::Request::Common::POST( '/dummy_location', Content_Type => 'form-data', Content => [ test_file => ["t/test_file.txt"], ] ); # Useful in simulating an upload. $ENV{REQUEST_METHOD} = 'POST'; $ENV{CONTENT_TYPE} = 'multipart/form-data'; $ENV{CONTENT_LENGTH} = $req->content_length; if ( open( CHILD, "|-" ) ) { print CHILD $req->content; close CHILD; exit 0; } use CGI::Uploader; my %imgs = ( 'test_file' => { gen_files => { 'test_file_gen' => { transform_method => \&test_gen_transform, } }, }, ); my $q = new CGI::Simple; my $u = CGI::Uploader->new( updir_path=>'t/uploads', updir_url=>'http://localhost/test', dbh => $DBH, query => $q, spec => \%imgs, ); ok($u, 'Uploader object creation'); my $form_data = $q->Vars; use Data::Dumper; warn Dumper ($form_data); my ($entity); eval { $entity = $u->store_uploads($form_data) }; is($@,'', 'calling store_uploads'); ok(not(grep {m/^(test_file)$/} keys %$entity), 'store_uploads entity removals work'); my @files = ; ok(scalar @files == 2, 'expected number of files created'); my $id_of_test_file_parent = 1; my $id_of_test_file_gen = 2; my $new_file_contents = read_file("t/uploads/$id_of_test_file_gen.asc"); like($new_file_contents,qr/gen/, "generated file is as expected"); $Test::DatabaseRow::dbh = $DBH; row_ok( sql => "SELECT * FROM uploads ORDER BY upload_id LIMIT 1", tests => { 'eq' => { mime_type => 'text/plain', extension => '.txt', }, '=~' => { upload_id => qr/^\d+/, }, } , label => "reality checking a database row"); my $row_cnt = $DBH->selectrow_array("SELECT count(*) FROM uploads "); is($row_cnt,2, 'number of rows in database'); # test fk_meta() { # mysql has a funny way of quoting # my $qt = ($drv eq 'mysql') ? '`' : '"'; ok($DBH->do(qq!INSERT INTO cgi_uploader_test (item_id,test_file_id,test_file_gen_id) VALUES (1, $id_of_test_file_parent, $id_of_test_file_gen)!), 'test data insert'); my $tmpl_vars_ref = $u->fk_meta( table => 'cgi_uploader_test', where => {item_id => 1}, prefixes => [qw/test_file test_file_gen/]); ok (eq_set( [qw/ test_file_url test_file_id test_file_gen_url test_file_gen_id /], [keys %$tmpl_vars_ref], ), 'fk_meta keys returned') || diag Dumper($tmpl_vars_ref); row_ok( sql => "SELECT * FROM uploads WHERE upload_id= $id_of_test_file_gen", tests => [ mime_type => 'text/plain', extension => '.asc', width => undef, height => undef, gen_from_id => $id_of_test_file_parent, ], label => "upload for thumb of generated test file is all good"); } my $LoH = $DBH->selectall_arrayref("SELECt * FROM uploads",{Slice=>{}}); # # Simulate another upload, { my %entity_upload_extra = $u->store_upload( file_field => 'test_file', src_file => 't/200x200.gif', uploaded_mt => 'image/gif', file_name => '200x200.gif', id_to_update => $id_of_test_file_parent, ); row_ok( sql => "SELECT * FROM uploads WHERE upload_id= $id_of_test_file_parent", tests => [ mime_type => 'image/gif', extension => '.gif', width => 200, height => 200, gen_from_id => undef, ], label => "image that had the ID of the test file should house a 200x200 image"); } { ok((!-e 't/uploads/1.txt'), 'after replacing a file, the extension changes') || diag read_file('t/uploads/1.txt'); } { my $found_old_thumbs = $DBH->selectcol_arrayref(" SELECT upload_id FROM uploads WHERE upload_id IN ($id_of_test_file_gen)"); is(scalar @$found_old_thumbs,0, 'The original generated files of the test file should be deleted'); } { my $how_many_thumbs = $DBH->selectrow_array("SELECT count(upload_id) FROM uploads WHERE gen_from_id = $id_of_test_file_parent"); is($how_many_thumbs,1, '1 new thumbnail for this image should have been generated'); } { $q->param('test_file_delete',1); $q->param('test_file_id',$id_of_test_file_parent); my @deleted_field_ids = $u->delete_checked_uploads; my @cmp_array = (\@deleted_field_ids,['test_file_id', 'test_file_gen_id']); ok(eq_set(@cmp_array), 'delete_checked_uploads returned field ids') || diag Dumper (@cmp_array); @files = ; ok(scalar @files == 0, 'expected number of files removed') || diag Dumper (\@files); $row_cnt = $DBH->selectrow_array("SELECT count(*) FROM uploads "); ok($row_cnt == 0, "Expected number of rows remaining: ($row_cnt)"); } CGI-Uploader-2.18/t/build_loc.t0000644000175000017500000000146211522147332014654 0ustar markmarkuse Test::More 'no_plan'; use Carp::Assert; use lib 't/lib'; use CGI::Uploader::Test; use strict; use CGI::Uploader; use Digest::MD5; use File::Path; use DBI; use CGI; my ($DBH,$drv) = setup(); my %imgs = ( 'img_1' => [], ); use CGI; my $q = CGI->new; my $u = CGI::Uploader->new( updir_path=>'t/uploads', updir_url=>'http://localhost/test', dbh => $DBH, spec => \%imgs, query => $q, file_scheme => 'md5', ); ok($u, 'Uploader object creation'); my $loc; eval { $loc = $u->build_loc('123','.jpg'); }; is($@,'', 'build_loc() survives'); is($loc, '2/0/2/123.jpg', "file_scheme => 'md5' works"); # We use an end block to clean up even if the script dies. END { rmtree(['t/uploads/2']); }; CGI-Uploader-2.18/t/create_test_table.sql0000644000175000017500000000025511522141350016716 0ustar markmarkCREATE TABLE cgi_uploader_test ( item_id int primary key not null, test_file_id int, test_file_gen_id int, "100x100_gif_id" int, img_1_thumb_1_id int ) CGI-Uploader-2.18/t/gen_thumb.t0000644000175000017500000000566011522147376014704 0ustar markmarkuse Test::More; use lib 't/lib'; use DBI; use Carp::Assert; use CGI::Uploader::Test; # provides setup() and read_file() use strict; use CGI::Uploader; use File::Path; my $found_module = 0; eval { require Image::Magick; }; $found_module = !$@; if ($found_module) { plan (qw/no_plan/) } else { eval { require Graphics::Magick; }; $found_module = !$@; if ($found_module) { plan (qw/no_plan/) } else { plan skip_all => "No graphics module found for image resizing. Install Graphics::Magick or Image::Magick: $@ "; } } use CGI::Uploader::Transform::ImageMagick; # This should work, even if we don't preload either one delete $INC{'Image/Magick.pm'}; delete $INC{'Graphics/Magick.pm'}; my ($tmp_filename, $img) = CGI::Uploader::Transform::ImageMagick->gen_thumb( 't/20x16.png', [ w => 5 ]); my ($w,$h) = $img->Get('width','height'); is($w,5,'as class method - correct height only width is supplied'); is($h,4,'as class method - correct height only width is supplied'); #### my ($DBH,$drv) = setup(); my %imgs = ( 'img_1' => { gen_files => { # old API img_1_thumb => { transform_method => \&gen_thumb, params => [{ w => 10 }], }, # new API new_api_thumb => gen_thumb({ w => 10}), }, }, ); use CGI; my $u = CGI::Uploader->new( updir_path=>'t/uploads', updir_url=>'http://localhost/test', dbh => $DBH, spec => \%imgs, query => CGI->new(), ); ok($u, 'Uploader object creation'); { my ($tmp_filename,$img) = CGI::Uploader::Transform::ImageMagick->gen_thumb({ filename => 't/20x16.png', w => 10, }); my ($w,$h) = $img->Get('width','height'); is($h,8,'correct height only width is supplied (also testing new API)'); } { my ($tmp_filename,$img) = CGI::Uploader::Transform::ImageMagick->gen_thumb({ filename => 't/20x16.png', h => 8, }); my ($w,$h) = $img->Get('width','height'); is($w,10,'correct width only width is supplied (also testing new API'); } eval { my %entity_upload_extra = $u->store_upload( file_field => 'img_1', src_file => 't/20x16.png', uploaded_mt => 'image/png', file_name => '20x16.png', ); }; is($@,'', 'store_upload() survives'); my $db_height =$DBH->selectrow_array( "SELECT height FROM uploads WHERE upload_id = 2"); is($db_height, 8, "correct height calculation when thumb height omitted from spec "); { my $db_height =$DBH->selectrow_array( "SELECT height FROM uploads WHERE upload_id = 3"); is($db_height, 8, "correct height calculation when thumb height omitted from spec (using new API) "); } CGI-Uploader-2.18/t/tmp/0000755000175000017500000000000011522150471013326 5ustar markmarkCGI-Uploader-2.18/t/tmp/.empty0000644000175000017500000000000011522141350014447 0ustar markmarkCGI-Uploader-2.18/t/pod.t0000644000175000017500000000020211522141350013463 0ustar markmarkuse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); CGI-Uploader-2.18/t/uploads/0000755000175000017500000000000011522150471014175 5ustar markmarkCGI-Uploader-2.18/t/uploads/.empty0000644000175000017500000000000011522141350015316 0ustar markmarkCGI-Uploader-2.18/t/cgi-uploader.config0000644000175000017500000000012111522150467016267 0ustar markmark$dsn = q!dbi:SQLite:dbname=t/test.db!; $user = q!!; $password = q!!; 1; CGI-Uploader-2.18/t/20x16.png0000644000175000017500000000012411522141350014005 0ustar markmarkPNG  IHDRzLIDATxcH@.`bj<ښ`*jIENDB`CGI-Uploader-2.18/t/meta.t0000644000175000017500000000507611522147240013651 0ustar markmarkuse Test::More; Test::More->builder->no_ending(1); use Config; use Carp::Assert; use lib 't/lib'; use strict; use CGI::Uploader; use DBI; use CGI; use HTTP::Request::Common; use CGI::Uploader::Test; $| = 1; if (! $Config{d_fork} ) { plan skip_all => "fork not available on this platform"; } else { plan tests => 12; } my ($DBH, $drv) = setup(); my $req = &HTTP::Request::Common::POST( '/dummy_location', Content_Type => 'form-data', Content => [ test_file => ["t/test_file.txt"], ] ); # Useful in simulating an upload. $ENV{REQUEST_METHOD} = 'POST'; $ENV{CONTENT_TYPE} = 'multipart/form-data'; $ENV{CONTENT_LENGTH} = $req->content_length; if ( open( CHILD, "|-" ) ) { print CHILD $req->content; close CHILD; exit 0; } my $q = new CGI; $DBH->do("ALTER TABLE uploads ADD COLUMN custom char(64)"); my %imgs = ( 'test_file' => { gen_files => { test_file_gen => { transform_method => \&test_gen_transform }, }, }, ); my $u = CGI::Uploader->new( updir_path=>'t/uploads', updir_url=>'http://localhost/test', dbh => $DBH, query => $q, spec => \%imgs, up_table_map => { upload_id => 'upload_id', mime_type => 'mime_type', extension => 'extension', width => 'width', height => 'height', custom => undef, } ); ok($u, 'Uploader object creation'); eval { my %entity_upload_extra = $u->store_upload( file_field => 'test_file', src_file => 't/test_file.txt', uploaded_mt => 'test/plain', file_name => 'test_file.txt', shared_meta => { custom => 'custom_value' }, ); }; is($@,'', 'store_upload() survives'); my $imgs_with_custom_value =$DBH->selectrow_array( "SELECT count(*) FROM uploads WHERE custom = 'custom_value'"); is($imgs_with_custom_value,2, 'both parent and generated file have shared_meta'); # testing transform_meta my $img_href = $DBH->selectrow_hashref("SELECT * FROM uploads WHERE upload_id = 1"); my %meta = $u->transform_meta( meta => $img_href, prefix => 'test', prevent_browser_caching => 1, fields => [qw/id url width height/], ); is($meta{test_id}, 1, 'meta_hashref id'); ok((not exists $meta{test_extension}), 'meta_hashref extension'); like($meta{test_url}, qr!http://localhost/test/1.txt\?!, 'meta_hashref url'); CGI-Uploader-2.18/t/test_file.txt0000644000175000017500000000002711522141350015240 0ustar markmarkThis is my test file. CGI-Uploader-2.18/t/lib/0000755000175000017500000000000011522150471013274 5ustar markmarkCGI-Uploader-2.18/t/lib/CGI/0000755000175000017500000000000011522150471013676 5ustar markmarkCGI-Uploader-2.18/t/lib/CGI/Uploader/0000755000175000017500000000000011522150471015451 5ustar markmarkCGI-Uploader-2.18/t/lib/CGI/Uploader/Test.pm0000644000175000017500000000610611522141350016725 0ustar markmarkpackage CGI::Uploader::Test; use Test::More; use Carp; use base 'Exporter'; use strict; # These vars are package-scope so we can call them in the END block. use vars (qw/@EXPORT $DBH $drv $created_up_table $created_test_table /); @EXPORT = (qw/ &setup &read_file &test_gen_transform /); =head2 setup my ($DBH,$drv) = setup(); Set up empty database tables for testing and return a database handle. Runs some Test::More Tests. Dies if there is a problem. =cut sub setup { my %p = @_; use vars qw($dsn $user $password); my $file ='t/cgi-uploader.config'; my $return; unless ($return = do $file) { warn "couldn't parse $file: $@" if $@; warn "couldn't do $file: $!" unless defined $return; warn "couldn't run $file" unless $return; } # For SQLite unlink ; ok($return, 'loading configuration'); $DBH = DBI->connect($dsn,$user,$password); ok($DBH,'connecting to database'), # create uploads table $drv = $DBH->{Driver}->{Name}; if ($drv eq 'SQLite') { # diag "testing with SQLite version: " .$DBH->selectrow_array("SELECT sqlite_version()"); } if (not $p{skip_create_uploader_table}) { ok(open(IN, "); $created_up_table = $DBH->do($sql); ok($created_up_table, 'creating uploads table'); } ok(open(IN, "); # Fix mysql non-standard quoting $item_tbl_sql =~ s/"/`/gs if ($drv eq 'mysql'); $created_test_table = $DBH->do($item_tbl_sql); ok($created_test_table, 'creating test table') || croak; return ($DBH,$drv); } =head2 read_file my $file_contents_as_one_line = read_file('file.txt'); Slurp a file, like File::Slurp; =cut sub read_file { my $file = shift; local( $/, *FH ); open( FH, $file ) or croak "failed to open file: $file: $!\n"; my $text = ; return $text; } # A trivial transform method for testing sub test_gen_transform { my $self = shift; my $path = shift; my $file_contents = read_file($path); $file_contents =~ s/test/generated/; # remove possible leading "t/" $path =~ s?^t/??; my $new_path = "t/$path".'.gen'; open(OUT, ">$new_path") || croak "can't open $new_path"; print OUT $file_contents; close(OUT); return $new_path; } # We use an end block to clean up even if the script dies. END { unlink ; if ($DBH) { # For SQLite, just delete the whole database file. :) if ($drv eq 'SQLite') { $DBH->disconnect; unlink ; } else { if ($created_up_table) { $DBH->do("DROP SEQUENCE upload_id_seq") if ($drv eq 'Pg'); $DBH->do("DROP TABLE uploads"); } if ($created_test_table) { $DBH->do('DROP TABLE cgi_uploader_test'); } } $DBH->disconnect; } }; 1; CGI-Uploader-2.18/t/200x200.gif0000755000175000017500000000242211522141350014127 0ustar markmarkGIF89a@@@000pppߟ PPP```!,#dihlp,+dx|pH,<rl:ШO)Zجz`"7L.z?:~ϏE;}vmfyolRMFAIKįǫʧͣПӛ֗ٓ܏ߋ됹&p !Lm!n(qŊ.bLq#߅<8S^NԢr%. $M83o>ɩ͞jxE"t(FM:d)SZH*%ժ/9p@G!(s t BXm< -7WGt@BO@r0`mk$xǀ i[7r9@xj0nbΦ}  jƞ 4XSsR!%B{ha@>rqk*0n˹wKx`a{ס? %HT` `^ oL @f$Ks! c lgtPq;{} :9xd.t@|0`V-b DYf@|p-0؇"1bC(<#hc8]@G@ه&!&!go6$W6 Uzݜۓ@ ,6h~thz)jg g8FXx װ7}y)`_] &-.ElUJUS2nRPa@>a (@"[} P7H@Y?6FQbȥ?Ȑ-@.g(2Э6eA`b  2 ^ 8+&WR7jfs,0A$ 00+bn#w9.ὒ(]#!^1 AQ>MwjoYcޏN7N.΍ne0@/JlSh?]nV?_`@'-H :dA;CGI-Uploader-2.18/t/basic.t0000644000175000017500000001362411522141350013776 0ustar markmark######################### use Test::More; # This allows me to fork without the test system having a cow. # I can't run any more tests in the parent after I do this. # See: http://perlmonks.org/?node_id=469077 # Thanks, Cees. Test::More->builder->no_ending(1); use Carp::Assert; use Data::Dumper; use DBI; use CGI; use Test::DatabaseRow; use HTTP::Request::Common; use lib 't/lib'; use CGI::Uploader::Test; # provides setup() and read_file() use Config; use strict; $| = 1; if (! $Config{d_fork} ) { plan skip_all => "fork not available on this platform"; } else { plan tests => 24; } my ($DBH,$drv) = setup(); my $req = &HTTP::Request::Common::POST( '/dummy_location', Content_Type => 'form-data', Content => [ test_file => ["t/test_file.txt"], ] ); # Useful in simulating an upload. $ENV{REQUEST_METHOD} = 'POST'; $ENV{CONTENT_TYPE} = 'multipart/form-data'; $ENV{CONTENT_LENGTH} = $req->content_length; if ( open( CHILD, "|-" ) ) { print CHILD $req->content; close CHILD; exit 0; } use CGI::Uploader; use CGI; my %imgs = ( 'test_file' => { gen_files => { 'test_file_gen' => \&test_gen_transform, }, }, ); my $q = new CGI; my $u = CGI::Uploader->new( updir_path=>'t/uploads', updir_url=>'http://localhost/test', dbh => $DBH, query => $q, spec => \%imgs, ); ok($u, 'Uploader object creation'); my $form_data = $q->Vars; my ($entity); eval { $entity = $u->store_uploads($form_data) }; is($@,'', 'calling store_uploads'); ok(not(grep {m/^(test_file)$/} keys %$entity), 'store_uploads entity removals work'); my @files = ; ok(scalar @files == 2, 'expected number of files created'); # We jump through this hoop because the MIME type detector # may have chosen ".txt" or "*.asc" for the file extension. my ($test_file_parent) = grep { /1/ } @files; my ($test_file_gen ) = grep { /2/ } @files; my $id_of_test_file_parent = 1; my $id_of_test_file_gen = 2; my $new_file_contents; eval { $new_file_contents = read_file($test_file_gen); }; # Maybe the file was detected as *.asc instead, so try that. is($@, '', 'survived eval') || diag `ls -l t/uploads/`; like($new_file_contents,qr/gen/, "generated file is as expected"); $Test::DatabaseRow::dbh = $DBH; row_ok( sql => "SELECT * FROM uploads ORDER BY upload_id LIMIT 1", tests => { 'eq' => { mime_type => 'text/plain', extension => '.txt', }, '=~' => { upload_id => qr/^\d+/, }, } , label => "reality checking a database row"); my $row_cnt = $DBH->selectrow_array("SELECT count(*) FROM uploads "); is($row_cnt,2, 'number of rows in database'); # test fk_meta() { # mysql has a funny way of quoting # my $qt = ($drv eq 'mysql') ? '`' : '"'; ok($DBH->do(qq!INSERT INTO cgi_uploader_test (item_id,test_file_id,test_file_gen_id) VALUES (1, $id_of_test_file_parent, $id_of_test_file_gen)!), 'test data insert'); my $tmpl_vars_ref = $u->fk_meta( table => 'cgi_uploader_test', where => {item_id => 1}, prefixes => [qw/test_file test_file_gen/]); ok (eq_set( [qw/ test_file_url test_file_id test_file_gen_url test_file_gen_id /], [keys %$tmpl_vars_ref], ), 'fk_meta keys returned') || diag Dumper($tmpl_vars_ref); row_ok( sql => "SELECT * FROM uploads WHERE upload_id= $id_of_test_file_gen", tests => [ mime_type => 'text/plain', extension => '.txt', width => undef, height => undef, gen_from_id => $id_of_test_file_parent, ], label => "upload for thumb of generated test file is all good"); } my $LoH = $DBH->selectall_arrayref("SELECt * FROM uploads",{Slice=>{}}); # # Simulate another upload, { my %entity_upload_extra = $u->store_upload( file_field => 'test_file', src_file => 't/200x200.gif', uploaded_mt => 'image/gif', file_name => '200x200.gif', id_to_update => $id_of_test_file_parent, ); row_ok( sql => "SELECT * FROM uploads WHERE upload_id= $id_of_test_file_parent", tests => [ mime_type => 'image/gif', extension => '.gif', width => 200, height => 200, gen_from_id => undef, ], label => "image that had the ID of the test file should house a 200x200 image"); } { ok((!-e 't/uploads/1.txt'), 'after replacing a file, the extension changes') || diag read_file('t/uploads/1.txt'); } { my $found_old_thumbs = $DBH->selectcol_arrayref(" SELECT upload_id FROM uploads WHERE upload_id IN ($id_of_test_file_gen)"); is(scalar @$found_old_thumbs,0, 'The original generated files of the test file should be deleted'); } { my $how_many_thumbs = $DBH->selectrow_array("SELECT count(upload_id) FROM uploads WHERE gen_from_id = $id_of_test_file_parent"); is($how_many_thumbs,1, '1 new thumbnail for this image should have been generated'); } { $q->param('test_file_delete',1); $q->param('test_file_id',$id_of_test_file_parent); my @deleted_field_ids = $u->delete_checked_uploads; my @cmp_array = (\@deleted_field_ids,['test_file_id', 'test_file_gen_id']); ok(eq_set(@cmp_array), 'delete_checked_uploads returned field ids') || diag Dumper (@cmp_array); @files = ; ok(scalar @files == 0, 'expected number of files removed') || diag Dumper (\@files); $row_cnt = $DBH->selectrow_array("SELECT count(*) FROM uploads "); ok($row_cnt == 0, "Expected number of rows remaining: ($row_cnt)"); } CGI-Uploader-2.18/t/up_table_map.t0000644000175000017500000001110011522147433015340 0ustar markmarkuse Test::More; Test::More->builder->no_ending(1); use lib 'lib'; use strict; use HTTP::Request::Common; use lib 't/lib'; use CGI::Uploader::Test; # provides setup() and read_file() use Config; use CGI::Uploader; use DBI; use CGI; use Test::DatabaseRow; $| = 1; if (! $Config{d_fork} ) { plan skip_all => "fork not available on this platform"; } else { plan tests => 19; } # skip default table create to do it ourselves later. my ($DBH,$drv) = setup(skip_create_uploader_table => 1); my $req = &HTTP::Request::Common::POST( '/dummy_location', Content_Type => 'form-data', Content => [ test_file => ["t/test_file.txt"], ] ); # Useful in simulating an upload. $ENV{REQUEST_METHOD} = 'POST'; $ENV{CONTENT_TYPE} = 'multipart/form-data'; $ENV{CONTENT_LENGTH} = $req->content_length; if ( open( CHILD, "|-" ) ) { print CHILD $req->content; close CHILD; exit 0; } my $q = new CGI; ok(open(IN, "); # We alter the table to test our mapping $sql =~ s/upload_id /upload_id_b /g; $sql =~ s/mime_type/mime_type_b/; $sql =~ s/extension/extension_b/; $sql =~ s/width/width_b/; $sql =~ s/height/height_b/; $sql =~ s/gen_from_id/gen_from_id_b/; my $created_up_table = $DBH->do($sql); ok($created_up_table, 'creating uploads table'); $DBH->do("ALTER TABLE uploads ADD COLUMN custom char(64)"); my %imgs = ( 'test_file' => { gen_files => { 'test_file_gen' => { transform_method => \&test_gen_transform, } }, }, ); my $u = CGI::Uploader->new( updir_path=>'t/uploads', updir_url=>'http://localhost/test', dbh => $DBH, query => $q, spec => \%imgs, up_table_map => { upload_id => 'upload_id_b', mime_type => 'mime_type_b', extension => 'extension_b', width => 'width_b', height => 'height_b', gen_from_id => 'gen_from_id_b', custom => undef, } ); ok($u, 'Uploader object creation'); my $form_data = $q->Vars; my ($entity); eval { ($entity) = $u->store_uploads($form_data); }; is($@,'', 'calling store_uploads'); my @pres = $u->spec_names; ok(eq_set([grep {m/_id$/} keys %$entity ],[map { $_.'_id'} @pres]), 'store_uploads entity additions work'); ok(not(grep {m/^(test_file)$/} keys %$entity), 'store_uploads entity removals work'); my @files = ; ok(scalar @files == 2, 'expected number of files created'); $Test::DatabaseRow::dbh = $DBH; row_ok( sql => "SELECT * FROM uploads ORDER BY upload_id_b LIMIT 1", tests => { 'eq' => { mime_type_b => 'text/plain', extension_b => '.txt', }, '=~' => { upload_id_b => qr/^\d+/, }, } , label => "reality checking a database row"); my $row_cnt = $DBH->selectrow_array("SELECT count(*) FROM uploads "); is($row_cnt,2, 'number of rows in database'); { ok($DBH->do(qq!INSERT INTO cgi_uploader_test (item_id,test_file_id,test_file_gen_id) VALUES (1,1,2)!), 'test data insert'); my $tmpl_vars_ref = $u->fk_meta( table => 'cgi_uploader_test', where => {item_id => 1}, prefixes => [qw/test_file test_file_gen/]); use Data::Dumper; ok (eq_set( [qw/ test_file_url test_file_id test_file_gen_url test_file_gen_id /], [keys %$tmpl_vars_ref], ), 'fk_meta keys returned') || diag Dumper($tmpl_vars_ref); like($tmpl_vars_ref->{test_file_url}, qr/1\.txt/, "fk_meta URLs look correct"); } $q->param('test_file_id',1); $q->param('test_file_delete',1); my @deleted_field_ids = $u->delete_checked_uploads; my @cmp_array = (\@deleted_field_ids,['test_file_id', 'test_file_gen_id']); ok(eq_set(@cmp_array), 'delete_checked_uploads returned field ids') || diag Dumper (@cmp_array); @files = ; is((scalar @files),0, 'expected number of files removed'); $row_cnt = $DBH->selectrow_array("SELECT count(*) FROM uploads "); is($row_cnt,0, 'number of rows removed'); # my $all = $DBH->selectall_arrayref("SELECT * from uploads",{ Slice => {}}); # use Data::Dumper; # warn Dumper ($all); CGI-Uploader-2.18/create_uploader_table.Pg.sql0000644000175000017500000000062311522141350017653 0ustar markmarkCREATE SEQUENCE upload_id_seq; CREATE TABLE uploads ( upload_id int primary key not null default nextval('upload_id_seq'), file_name character varying(255), mime_type character varying(64), extension character varying(8), -- file extension width integer, height integer, -- refer to the ID of the image used to create this thumbnail, if any gen_from_id integer ) CGI-Uploader-2.18/create_uploader_table.SQLite.sql0000644000175000017500000000064611522141350020453 0ustar markmarkCREATE TABLE uploads ( -- Notice AUTOINCREMENT has no underscore like MySQL does. upload_id INTEGER primary key AUTOINCREMENT NOT NULL, file_name character varying(255), mime_type character varying(64), extension character varying(8), -- file extension width integer, height integer, -- refer to the ID of the image used to create this thumbnail, if any gen_from_id integer )