the maxlength field from the supplied field list was being dropped
[bse.git] / site / cgi-bin / modules / DevHelp / FileUpload.pm
CommitLineData
3c32512d
TC
1package DevHelp::FileUpload;
2use strict;
3use IO::File;
4use File::Copy;
5
6=head1 NAME
7
8 DevHelp::FileUpload - tools to maintain a file upload directory
9
10=head1 SYNOPSIS
11
12 use DevHelp::FileUpload;
13
14 my $msg;
15 my ($name, $handle) =
16 DevHelp::FileUpload->make_img_filename($image_dir, $original_name, \$msg)
17 or die $msg;
18 my $newname =
19 DevHelp::FileUpload->make_img_copy($image_dir, $oldname, \$msg)
20 or die $msg;
21
22=head1 DESCRIPTION
23
24=over
25
26=item DevHelp::FileUpload->make_img_copy($imgdir, $oldname, \$msg)
27
28=cut
29
30sub make_img_copy {
31 my ($class, $imgdir, $oldname, $rmsg) = @_;
32
33 # remove the time value and optional counter
34 (my $workname = $oldname) =~ s/^\d+_(?:\d+_)?//;
35
36 my ($newname, $fh) = $class->make_img_filename($imgdir, $workname, $rmsg)
37 or return;
38
39 unless (copy("$imgdir/$oldname", $fh)) {
40 $$rmsg = "Cannot copy to new file: $!";
41 close $fh; undef $fh;
42 unlink "$imgdir/$newname";
43 return;
44 }
45
46 close $fh;
47 undef $fh;
48
49 return $newname;
50}
51
52=item DevHelp::FileUpload->make_img_filename($imgdir, $name, \$msg)
53
54=cut
55
56sub make_img_filename {
57 my ($class, $imgdir, $name, $rmsg) = @_;
58
59 my $basename = '';
60 $name =~ /([\w.-]+)$/ and $basename = $1;
61
62 my $filename = time . '_' . $basename;
63
64 my $fh;
65 my $counter = "";
66 $filename = time . '_' . $counter . '_' . $basename
67 until $fh = IO::File->new("$imgdir/$filename", O_CREAT | O_WRONLY | O_EXCL)
68 or ++$counter > 100;
69
70 unless ($fh) {
71 $$rmsg = "Could not open image file $imgdir/$filename: $!";
72 return;
73 }
74
75 binmode $fh;
76
77 return ($filename, $fh);
78}
79
80=back
81
82=head1 AUTHOR
83
84Tony Cook <tony@develop-help.com>
85
86=cut
87
881;