document iterator cfgsection
[bse.git] / site / cgi-bin / modules / DevHelp / FileUpload.pm
CommitLineData
3c32512d
TC
1package DevHelp::FileUpload;
2use strict;
3use IO::File;
4use File::Copy;
5
cb7fd78d
TC
6our $VERSION = "1.000";
7
3c32512d
TC
8=head1 NAME
9
10 DevHelp::FileUpload - tools to maintain a file upload directory
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
54=item DevHelp::FileUpload->make_img_filename($imgdir, $name, \$msg)
55
56=cut
57
58sub make_img_filename {
59 my ($class, $imgdir, $name, $rmsg) = @_;
60
61 my $basename = '';
62 $name =~ /([\w.-]+)$/ and $basename = $1;
63
4b69925d
TC
64 if (length $basename > 60) {
65 $basename = substr($basename, -60);
66 }
67
3c32512d
TC
68 my $filename = time . '_' . $basename;
69
70 my $fh;
71 my $counter = "";
72 $filename = time . '_' . $counter . '_' . $basename
73 until $fh = IO::File->new("$imgdir/$filename", O_CREAT | O_WRONLY | O_EXCL)
74 or ++$counter > 100;
75
76 unless ($fh) {
77 $$rmsg = "Could not open image file $imgdir/$filename: $!";
78 return;
79 }
80
81 binmode $fh;
82
83 return ($filename, $fh);
84}
85
86=back
87
88=head1 AUTHOR
89
90Tony Cook <tony@develop-help.com>
91
92=cut
93
941;