eliminate lone dashes
[bse.git] / site / cgi-bin / modules / DevHelp / FileUpload.pm
CommitLineData
3c32512d
TC
1package DevHelp::FileUpload;
2use strict;
3use IO::File;
4use File::Copy;
5
9acd2ec4 6our $VERSION = "1.003";
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;
9acd2ec4
TC
88 $basename =~ s/-\B//g;
89 $basename =~ s/\B-//g;
3c32512d 90
4b69925d
TC
91 if (length $basename > 60) {
92 $basename = substr($basename, -60);
93 }
94
3c32512d
TC
95 my $filename = time . '_' . $basename;
96
97 my $fh;
98 my $counter = "";
99 $filename = time . '_' . $counter . '_' . $basename
100 until $fh = IO::File->new("$imgdir/$filename", O_CREAT | O_WRONLY | O_EXCL)
101 or ++$counter > 100;
102
103 unless ($fh) {
104 $$rmsg = "Could not open image file $imgdir/$filename: $!";
105 return;
106 }
107
108 binmode $fh;
109
110 return ($filename, $fh);
111}
112
113=back
114
115=head1 AUTHOR
116
117Tony Cook <tony@develop-help.com>
118
119=cut
120
1211;