| Subject: | Updates to 1.1_1 |
Hey Mark,
Here's my tweaks to the dev release of C::U. It's somewhat extensive but here's the gist:
* Add support for SQLite
* Add name_scheme support
* Add support for parsing uploaded filename
* Add get_upload_record() method
* Add more error checking around store_file
* Do not require the third parameter ($ext) to build_loc
* Modifications to cleanup warning messages
I've run the tests but many of them fail b/c I'm too tired to setup a DSN. Perhaps you have an environment configured for testing this module and can confirm that all is still working properly. Sorry but I have not added tests for any of the new functionality yet. Let me know what you think. I look forward to making these features part of the stable release as I keep finding more uses for this module.
Thanks,
William
PS: I have written Apache::Test tests which can do upload test verification. Might be something to consider adding to the test suite. I think there are ways to check for A::T being installed or not and skip the tests or allow the user to install and setup A::T. We'd prob need to check that before adding these type of tests to a CPAN module.
--- lib/CGI/Uploader.pm.orig 2005-04-02 13:31:50.000000000 -0500
+++ lib/CGI/Uploader.pm 2005-07-07 03:21:31.000000000 -0400
@@ -12,7 +12,7 @@
require Exporter;
use vars qw($VERSION);
-$VERSION = '1.1_1';
+$VERSION = '1.1_2';
=head1 NAME
@@ -248,13 +248,17 @@
regex => qr/^simple|md5$/,
default => 'simple',
},
+ name_scheme => {
+ regex => qr/^id|file_name$/,
+ default => 'id',
+ },
});
$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')) {
- die "only mysql and Pg drivers are supported at this time. ";
+ unless (($in{db_driver} eq 'mysql') or ($in{db_driver} eq 'Pg') or ($in{db_driver} eq 'SQLite')) {
+ die "only mysql and Pg drivers are supported at this time. You are trying to use $in{db_driver}.";
}
unless ($in{query}) {
@@ -655,7 +659,11 @@
uploaded_mt => { type => SCALAR },
file_name => { type => SCALAR | GLOBREF },
shared_meta => { type => HASHREF | UNDEF, default => {} },
- id_to_update => { regex => qr/^\d*$/, optional => 1 },
+ # This line is causing a warning to be printed to the Apache error
+ # log by Params::Validate if id_to_update is not set; looks like
+ # an error since optional is set - WLM 2005-07-07
+ #id_to_update => { regex => qr/^\d*$/, optional => 1 },
+ id_to_update => { type => SCALAR | UNDEF, optional => 1 },
});
my (
@@ -679,7 +687,7 @@
my $meta = $self->extract_meta($tmp_filename,$file_name,$uploaded_mt);
$shared_meta ||= {};
- my $all_meta = { %$meta, %$shared_meta };
+ my $all_meta = { %$meta, %$shared_meta };
my $id;
# If it's an update
@@ -694,15 +702,14 @@
$all_meta,
$id );
-
$self->store_file($file_field,$id,$meta->{extension},$tmp_filename);
my %ids = $self->create_store_gen_files(
- file_field => $file_field,
- meta => $all_meta,
- src_file => $tmp_filename,
- gen_from_id => $id,
- );
+ file_field => $file_field,
+ meta => $all_meta,
+ src_file => $tmp_filename,
+ gen_from_id => $id,
+ ) || ();
return (%ids, $file_field.'_id' => $id);
@@ -863,7 +870,21 @@
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;
+ require File::Basename;
+ File::Basename::fileparse_set_fstype($client_os);
+ $file_name = File::Basename::fileparse($file_name,[]);
+ $file_name =~ s/\s+/_/g;
+
+ ## Extract only the basename of the uploaded file
+ #require File::Basename;
+ #my $file_name = fileparse($file_name,[]);
require File::MMagic;
my $mm = File::MMagic->new;
@@ -913,7 +934,7 @@
# Now get the image dimensions if it's an image
my ($width,$height) = imgsize($tmp_filename);
- return {
+ return {
file_name => $file_name,
mime_type => $mt,
extension => $ext,
@@ -937,7 +958,7 @@
- file field name
- - A hashref of key/value pairs to be store. Only the key names defined by the
+ - A hashref of key/value pairs to be stored. Only the key names defined by the
C<up_table_map> in C<new()> will be used. Other values in the hash will be
ignored.
@@ -999,6 +1020,9 @@
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;
}
@@ -1125,14 +1149,28 @@
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($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;
+ require File::Copy;
import File::Copy;
- copy($tmp_file, File::Spec->catdir($self->{updir_path},$self->build_loc($id,$ext)) )
- || die "Unexpected error occured when uploading the image: $!";
+ my $method = $self->{name_scheme};
+ if ($method eq 'id') {
+ my $dest = File::Spec->catdir($self->{updir_path},$self->build_loc($id,$ext));
+ copy($tmp_file, $dest )
+ || die "Unexpected error occured when copying the image to $dest: $!. Check your permissions.";
+ }
+ elsif ($method eq 'file_name') {
+ my $dest = File::Spec->catdir($self->{updir_path},$self->build_loc($id));
+ copy($tmp_file, $dest )
+ || die "Unexpected error occured when copying the image to $dest: $!. Check your permissions.";
+ }
+ else {
+ die "Unknown name_scheme - $method";
+ }
}
@@ -1185,15 +1223,18 @@
=cut
sub build_loc {
- validate_pos(@_,1,1,1);
+ validate_pos(@_,1,1,0);
my ($self,$id,$ext) = @_;
my $scheme = $self->{file_scheme};
+ my $method = $self->{name_scheme};
my $loc;
if ($scheme eq 'simple') {
- $loc = "$id$ext";
- }
+ return "$id$ext" if $method eq 'id';
+ my $meta = $self->get_upload_record($id);
+ return $meta->{file_name};
+ }
elsif ($scheme eq 'md5') {
require Digest::MD5;
import Digest::MD5 qw/md5_hex/;
@@ -1205,9 +1246,35 @@
mkpath($full_path);
}
- $loc = "$md5_path/$id$ext";
+ return "$md5_path/$id$ext" if $method eq 'id';
+ my $meta = $self->get_upload_record($id);
+ return "$md5_path/" . $meta->{file_name};
}
}
+
+
+=head2 get_upload_record()
+
+ my $upload_data = $self->get_file_name($id);
+
+Returns a hashref of data stored in the uploads database for the requested file id.
+
+=cut
+
+sub get_upload_record {
+ validate_pos(@_,1,1);
+ my ($self,$id) = @_;
+ my $DBH = $self->{dbh};
+
+ my @file_fields = $self->upload_field_names();
+
+ my $map = $self->{up_table_map};
+ my $h = $DBH->selectrow_hashref(
+ qq!SELECT * FROM ! . $self->{up_table} .
+ qq! WHERE ( $map->{upload_id} = ! . $DBH->quote($id) . qq! )!);
+}
+
+
=head2 upload_field_names()
# As a class method