allow more than a trailing alphanumeric part of an image filename to live
[bse.git] / site / cgi-bin / modules / DevHelp / FileUpload.pm
CommitLineData
3c32512d
TC
1package DevHelp::FileUpload;
2use strict;
3use IO::File;
4use File::Copy;
5
43c194df 6our $VERSION = "1.002";
cb7fd78d 7
3c32512d
TC
8=head1 NAME
9
43c194df 10DevHelp::FileUpload - tools to maintain a file upload directory
3c32512d
TC
11
12=head1 SYNOPSIS
13
14 use DevHelp::FileUpload;
15
16 my $msg;
17 my ($name, $handle) =
18 DevHelp::FileUpload->make_img_filename($image_dir, $original_name, \$msg)
19 or die $msg;
20 my $newname =
21 DevHelp::FileUpload->make_img_copy($image_dir, $oldname, \$msg)
22 or die $msg;
23
24=head1 DESCRIPTION
25
26=over
27
28=item DevHelp::FileUpload->make_img_copy($imgdir, $oldname, \$msg)
29
30=cut
31
32sub make_img_copy {
33 my ($class, $imgdir, $oldname, $rmsg) = @_;
34
35 # remove the time value and optional counter
36 (my $workname = $oldname) =~ s/^\d+_(?:\d+_)?//;
37
38 my ($newname, $fh) = $class->make_img_filename($imgdir, $workname, $rmsg)
39 or return;
40
41 unless (copy("$imgdir/$oldname", $fh)) {
42 $$rmsg = "Cannot copy to new file: $!";
43 close $fh; undef $fh;
44 unlink "$imgdir/$newname";
45 return;
46 }
47
48 close $fh;
49 undef $fh;
50
51 return $newname;
52}
53
bd903bc5
TC
54=item DevHelp::FileUpload->make_fh_copy($fh, $imgdir, $name, \$msg)
55
56=cut
57
58sub make_fh_copy {
59 my ($class, $fh, $imgdir, $name, $rmsg) = @_;
60
61 my ($newname, $out_fh) = $class->make_img_filename($imgdir, $name, $rmsg)
62 or return;
63
64 # $fh might be a CGI.pm special that confuses File::Copy
65 local $/ = \8192;
66 binmode $fh;
67 binmode $out_fh;
68 while (my $block = <$fh>) {
69 print $out_fh $block;
70 }
71 unless (close $out_fh) {
72 $$rmsg = "Cannot write work file: $!";
73 unlink "$imgdir/$newname";
74 return;
75 }
76
77 return $newname;
78}
79
3c32512d
TC
80=item DevHelp::FileUpload->make_img_filename($imgdir, $name, \$msg)
81
82=cut
83
84sub make_img_filename {
85 my ($class, $imgdir, $name, $rmsg) = @_;
86
43c194df 87 (my $basename = $name) =~ tr/A-Za-z0-9_./-/cs;
3c32512d 88
4b69925d
TC
89 if (length $basename > 60) {
90 $basename = substr($basename, -60);
91 }
92
3c32512d
TC
93 my $filename = time . '_' . $basename;
94
95 my $fh;
96 my $counter = "";
97 $filename = time . '_' . $counter . '_' . $basename
98 until $fh = IO::File->new("$imgdir/$filename", O_CREAT | O_WRONLY | O_EXCL)
99 or ++$counter > 100;
100
101 unless ($fh) {
102 $$rmsg = "Could not open image file $imgdir/$filename: $!";
103 return;
104 }
105
106 binmode $fh;
107
108 return ($filename, $fh);
109}
110
111=back
112
113=head1 AUTHOR
114
115Tony Cook <tony@develop-help.com>
116
117=cut
118
1191;