File Coverage

blib/lib/jQuery/File/Upload.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package jQuery::File::Upload;
2              
3 1     1   22554 use 5.008008;
  1         4  
  1         60  
4 1     1   6 use strict;
  1         3  
  1         36  
5             #use warnings;
6              
7 1     1   2165 use CGI;
  1         18616  
  1         7  
8 1     1   1377 use JSON::XS;
  1         7737  
  1         93  
9 1     1   1341 use JSON;
  1         7535  
  1         8  
10 1     1   2449 use Net::SSH2;
  0            
  0            
11             use Net::SSH2::SFTP;
12             use Image::Magick;
13             use Cwd 'abs_path';
14             use URI;
15             use Data::GUID;
16              
17             #use LWP::UserAgent;
18             #use LWP::Protocol::https;
19              
20             our $VERSION = '0.29';
21              
22             my %errors = (
23             '_validate_max_file_size' => 'File is too big',
24             '_validate_min_file_size' => 'File is too small',
25             '_validate_accept_file_types' => 'Filetype not allowed',
26             '_validate_reject_file_types' => 'Filetype not allowed',
27             '_validate_max_number_of_files' => 'Maximum number of files exceeded',
28             '_validate_max_width' => 'Image exceeds maximum width',
29             '_validate_min_width' => 'Image requires a minimum width',
30             '_validate_max_height' => 'Image exceeds maximum height',
31             '_validate_min_height' => 'Image requires a minimum height'
32             );
33              
34             #GETTERS/SETTERS
35             sub new {
36             my $invocant = shift;
37             my $class = ref($invocant) || $invocant;
38             my $self = {
39             field_name => 'files[]',
40             ctx => undef,
41             cgi => undef,
42             thumbnail_width => 80,
43             thumbnail_height => 80,
44             thumbnail_quality => 70,
45             thumbnail_format => 'jpg',
46             thumbnail_density => undef,
47             format => 'jpg',
48             quality => 70,
49              
50             thumbnail_filename => undef,
51             thumbnail_prefix => 'thumb_',
52             thumbnail_postfix => '',
53             filename => undef,
54             client_filename => undef,
55             show_client_filename => 1,
56             use_client_filename => undef,
57             filename_salt => '',
58             script_url => undef,
59             tmp_dir => '/tmp',
60             should_delete => 1,
61              
62             absolute_filename => undef,
63             absolute_thumbnail_filename => undef,
64              
65             delete_params => [],
66              
67             upload_dir => undef,
68             thumbnail_upload_dir => undef,
69             upload_url_base => undef,
70             thumbnail_url_base => undef,
71             relative_url_path => '/files',
72             thumbnail_relative_url_path => undef,
73             relative_to_host => undef,
74             delete_url => undef,
75              
76             data => {},
77              
78             #callbacks
79             post_delete => sub {},
80             post_post => sub {},
81             post_get => sub {},
82              
83             #pre calls
84             pre_delete => sub {},
85             pre_post => sub {},
86             pre_get => sub {},
87              
88             #scp/rcp login info
89             scp => [],
90              
91             #user validation specifications
92             max_file_size => undef,
93             min_file_size => 1,
94             accept_file_types => [],
95             reject_file_types => [],
96             require_image => undef,
97             max_width => undef,
98             max_height => undef,
99             min_width => 1,
100             min_height => 1,
101             max_number_of_files => undef,
102            
103             #not to be used by users
104             output => undef,
105             handle => undef,
106             tmp_filename => undef,
107             fh => undef,
108             error => undef,
109             upload => undef,
110             file_type => undef,
111             is_image => undef,
112             image_magick => undef,
113             width => undef,
114             height => undef,
115             num_files_in_dir => undef,
116             user_error => undef,
117             @_, # Override previous attributes
118             };
119             return bless $self, $class;
120             }
121              
122             sub upload_dir {
123             my $self = shift;
124            
125             if (@_) {
126             $self->{upload_dir} = shift;
127             }
128            
129             #set upload_dir to directory of this script if not provided
130             if(!(defined $self->{upload_dir})) {
131             $self->{upload_dir} = abs_path($0);
132             $self->{upload_dir} =~ s/(.*)\/.*/$1/;
133             $self->{upload_dir} .= '/files';
134             }
135              
136             return $self->{upload_dir};
137             }
138              
139             sub thumbnail_upload_dir {
140             my $self = shift;
141            
142             if (@_) {
143             $self->{thumbnail_upload_dir} = shift;
144             }
145            
146             #set upload_dir to directory of this script if not provided
147             if(!(defined $self->{thumbnail_upload_dir})) {
148             $self->{thumbnail_upload_dir} = $self->upload_dir;
149             }
150              
151             return $self->{thumbnail_upload_dir};
152             }
153              
154             sub upload_url_base {
155             my $self = shift;
156            
157             if (@_) {
158             $self->{upload_url_base} = shift;
159             }
160            
161             if(!(defined $self->{upload_url_base})) {
162             $self->{upload_url_base} = $self->_url_base . $self->relative_url_path;
163             }
164              
165             return $self->{upload_url_base};
166             }
167              
168             sub _url_base {
169             my $self = shift;
170             my $url;
171            
172             if($self->relative_to_host) {
173             $url = $self->{uri}->scheme . '://' . $self->{uri}->host;
174             }
175             else {
176             $url = $self->script_url;
177             $url =~ s/(.*)\/.*/$1/;
178             }
179              
180             return $url;
181             }
182              
183             sub thumbnail_url_base {
184             my $self = shift;
185            
186             if (@_) {
187             $self->{thumbnail_url_base} = shift;
188             }
189            
190             if(!(defined $self->{thumbnail_url_base})) {
191             if(defined $self->thumbnail_relative_url_path) {
192             $self->{thumbnail_url_base} = $self->_url_base . $self->thumbnail_relative_url_path;
193             }
194             else {
195             $self->{thumbnail_url_base} = $self->upload_url_base;
196             }
197             }
198              
199             return $self->{thumbnail_url_base};
200             }
201              
202              
203             sub relative_url_path {
204             my $self = shift;
205              
206             if(@_) {
207             $self->{relative_url_path} = shift;
208             }
209              
210             return $self->{relative_url_path};
211             }
212              
213             sub thumbnail_relative_url_path {
214             my $self = shift;
215              
216             if(@_) {
217             $self->{thumbnail_relative_url_path} = shift;
218             }
219              
220             return $self->{thumbnail_relative_url_path};
221             }
222              
223             sub relative_to_host {
224             my $self = shift;
225              
226             if(@_) {
227             $self->{relative_to_host} = shift;
228             }
229              
230             return $self->{relative_to_host};
231             }
232              
233              
234              
235             sub field_name {
236             my $self = shift;
237            
238             if (@_) {
239             $self->{field_name} = shift;
240             }
241            
242             return $self->{field_name};
243             }
244              
245             sub ctx {
246             my $self = shift;
247            
248             if (@_) {
249             $self->{ctx} = shift;
250             }
251            
252             return $self->{ctx};
253             }
254              
255             sub cgi {
256             my $self = shift;
257            
258             if (@_) {
259             $self->{cgi} = shift;
260             }
261             $self->{cgi} = CGI->new unless defined $self->{cgi};
262            
263             return $self->{cgi};
264             }
265              
266             sub should_delete {
267             my $self = shift;
268            
269             if (@_) {
270             $self->{should_delete} = shift;
271             }
272            
273             return $self->{should_delete};
274             }
275              
276             sub scp {
277             my $self = shift;
278            
279             if (@_) {
280             $self->{scp} = shift;
281             }
282            
283             return $self->{scp};
284             }
285              
286             sub max_file_size {
287             my $self = shift;
288            
289             if (@_) {
290             $self->{max_file_size} = shift;
291             }
292            
293             return $self->{max_file_size};
294             }
295              
296             sub min_file_size {
297             my $self = shift;
298            
299             if (@_) {
300             $self->{min_file_size} = shift;
301             }
302            
303             return $self->{min_file_size};
304             }
305              
306             sub accept_file_types {
307             my $self = shift;
308            
309             if (@_) {
310             my $a_ref = shift;
311             die "accept_file_types must be an array ref" unless UNIVERSAL::isa($a_ref,'ARRAY');
312             $self->{accept_file_types} = $a_ref;
313             }
314              
315             if(scalar(@{$self->{accept_file_types}}) == 0 and $self->require_image) {
316             $self->{accept_file_types} = ['image/jpeg','image/jpg','image/png','image/gif'];
317             }
318            
319             return $self->{accept_file_types};
320             }
321              
322             sub reject_file_types {
323             my $self = shift;
324            
325             if (@_) {
326             my $a_ref = shift;
327             die "reject_file_types must be an array ref" unless UNIVERSAL::isa($a_ref,'ARRAY');
328             $self->{reject_file_types} = $a_ref;
329             }
330              
331             return $self->{reject_file_types};
332             }
333              
334             sub require_image {
335             my $self = shift;
336            
337             if (@_) {
338             $self->{require_image} = shift;
339             }
340            
341             return $self->{require_image};
342             }
343              
344             sub delete_params {
345             my $self = shift;
346            
347             if (@_) {
348             my $a_ref = shift;
349             die "delete_params must be an array ref" unless UNIVERSAL::isa($a_ref,'ARRAY');
350             $self->{delete_params} = $a_ref;
351             }
352            
353             return $self->{delete_params};
354             }
355              
356             sub delete_url {
357             my $self = shift;
358              
359             if(@_) {
360             $self->{delete_url} = shift;
361             }
362              
363             return $self->{delete_url};
364             }
365              
366             sub thumbnail_width {
367             my $self = shift;
368            
369             if (@_) {
370             $self->{thumbnail_width} = shift;
371             }
372            
373             return $self->{thumbnail_width};
374             }
375              
376             sub thumbnail_height {
377             my $self = shift;
378            
379             if (@_) {
380             $self->{thumbnail_height} = shift;
381             }
382            
383             return $self->{thumbnail_height};
384             }
385              
386             sub thumbnail_quality {
387             my $self = shift;
388            
389             if (@_) {
390             $self->{thumbnail_quality} = shift;
391             }
392            
393             return $self->{thumbnail_quality};
394             }
395              
396             sub thumbnail_format {
397             my $self = shift;
398            
399             if (@_) {
400             $self->{thumbnail_format} = shift;
401             }
402            
403             return $self->{thumbnail_format};
404             }
405              
406             sub thumbnail_density {
407             my $self = shift;
408            
409             if (@_) {
410             $self->{thumbnail_density} = shift;
411             }
412            
413             return $self->{thumbnail_density};
414             }
415              
416             sub thumbnail_prefix {
417             my $self = shift;
418            
419             if (@_) {
420             $self->{thumbnail_prefix} = shift;
421             }
422            
423             return $self->{thumbnail_prefix};
424             }
425              
426             sub thumbnail_postfix {
427             my $self = shift;
428            
429             if (@_) {
430             $self->{thumbnail_postfix} = shift;
431             }
432            
433             return $self->{thumbnail_postfix};
434             }
435              
436             sub thumbnail_final_width {
437             my $self = shift;
438              
439             if(@_) {
440             $self->{thumbnail_final_width} = shift;
441             }
442              
443             return $self->{thumbnail_final_width};
444             }
445              
446             sub thumbnail_final_height {
447             my $self = shift;
448              
449             if(@_) {
450             $self->{thumbnail_final_height} = shift;
451             }
452              
453             return $self->{thumbnail_final_height};
454             }
455              
456             sub quality {
457             my $self = shift;
458            
459             if (@_) {
460             $self->{quality} = shift;
461             }
462            
463             return $self->{quality};
464             }
465              
466             sub format {
467             my $self = shift;
468            
469             if (@_) {
470             $self->{format} = shift;
471             }
472            
473             return $self->{format};
474             }
475              
476             sub final_width {
477             my $self = shift;
478              
479             if(@_) {
480             $self->{final_width} = shift;
481             }
482              
483             return $self->{final_width};
484             }
485              
486             sub final_height {
487             my $self = shift;
488              
489             if(@_) {
490             $self->{final_height} = shift;
491             }
492              
493             return $self->{final_height};
494             }
495              
496             sub max_width {
497             my $self = shift;
498            
499             if (@_) {
500             $self->{max_width} = shift;
501             }
502            
503             return $self->{max_width};
504             }
505              
506             sub max_height {
507             my $self = shift;
508            
509             if (@_) {
510             $self->{max_height} = shift;
511             }
512            
513             return $self->{max_height};
514             }
515              
516             sub min_width {
517             my $self = shift;
518            
519             if (@_) {
520             $self->{min_width} = shift;
521             }
522            
523             return $self->{min_width};
524             }
525              
526             sub min_height {
527             my $self = shift;
528            
529             if (@_) {
530             $self->{min_height} = shift;
531             }
532            
533             return $self->{min_height};
534             }
535              
536             sub max_number_of_files {
537             my $self = shift;
538            
539             if (@_) {
540             $self->{max_number_of_files} = shift;
541             }
542            
543             return $self->{max_number_of_files};
544             }
545              
546             sub filename {
547             my $self = shift;
548            
549             if (@_) {
550             $self->{filename} = shift;
551             }
552            
553             return $self->{filename};
554             }
555              
556             sub absolute_filename {
557             my $self = shift;
558            
559             if (@_) {
560             $self->{absolute_filename} = shift;
561             }
562            
563             return $self->{absolute_filename};
564             }
565              
566             sub thumbnail_filename {
567             my $self = shift;
568            
569             if (@_) {
570             $self->{thumbnail_filename} = shift;
571             }
572            
573             return $self->{thumbnail_filename};
574             }
575              
576             sub absolute_thumbnail_filename {
577             my $self = shift;
578            
579             if (@_) {
580             $self->{absolute_thumbnail_filename} = shift;
581             }
582            
583             return $self->{absolute_thumbnail_filename};
584             }
585              
586             sub client_filename {
587             my $self = shift;
588            
589             if (@_) {
590             $self->{client_filename} = shift;
591             }
592            
593             return $self->{client_filename};
594             }
595              
596             sub show_client_filename {
597             my $self = shift;
598            
599             if (@_) {
600             $self->{show_client_filename} = shift;
601             }
602            
603             return $self->{show_client_filename};
604             }
605              
606             sub use_client_filename {
607             my $self = shift;
608            
609             if (@_) {
610             $self->{use_client_filename} = shift;
611             }
612            
613             return $self->{use_client_filename};
614             }
615              
616             sub filename_salt {
617             my $self = shift;
618            
619             if (@_) {
620             $self->{filename_salt} = shift;
621             }
622            
623             return $self->{filename_salt};
624             }
625              
626             sub tmp_dir {
627             my $self = shift;
628            
629             if (@_) {
630             $self->{tmp_dir} = shift;
631             }
632            
633             return $self->{tmp_dir};
634             }
635              
636             sub script_url {
637             my $self = shift;
638            
639             if (@_) {
640             $self->{script_url} = shift;
641             }
642            
643             if(!(defined $self->{script_url})) {
644             if(defined $self->ctx) {
645             $self->{script_url} = $self->ctx->request->uri;
646             }
647             else {
648             $self->{script_url} = $ENV{SCRIPT_URI};
649             }
650             }
651              
652             return $self->{script_url};
653             }
654              
655             sub data {
656             my $self = shift;
657              
658             if(@_) {
659             $self->{data} = shift;
660             }
661              
662             return $self->{data};
663             }
664              
665             #GETTERS
666             sub output { shift->{output} }
667             sub url { shift->{url} }
668             sub thumbnail_url { shift->{thumbnail_url} }
669             sub is_image { shift->{is_image} }
670             sub size { shift->{file_size} }
671              
672             #OTHER METHODS
673             sub print_response {
674             my $self = shift;
675              
676             my $content_type = 'text/plain';
677             if(defined $self->ctx) {
678              
679             #thanks to Lukas Rampa for this suggestion
680             if ($self->ctx->req->headers->header('Accept') =~ qr(application/json) ) {
681             $content_type = 'application/json';
682             }
683              
684             $self->ctx->stash->{current_view} = '';
685             $self->ctx->res->content_type("$content_type; charset=utf-8");
686             $self->ctx->res->body($self->output . ""); #concatenate "" for when there is no output
687             }
688             else {
689             print "Content-type: $content_type\n\n";
690             print $self->output;
691             }
692             }
693              
694             sub handle_request {
695             my $self = shift;
696             my ($print) = @_;
697              
698             my $method = $self->_get_request_method;
699              
700             if($method eq 'GET') {
701             &{$self->pre_get}($self);
702             &{$self->post_get}($self);
703             }
704             elsif($method eq 'PATCH' or $method eq 'POST' or $method eq 'PUT') {
705             $self->{user_error} = &{$self->pre_post}($self);
706             unless($self->{user_error}) {
707             $self->_post;
708             &{$self->post_post}($self);
709             }
710             else { $self->_generate_output }
711             }
712             elsif($method eq 'DELETE') {
713             $self->{user_error} = &{$self->pre_delete}($self); #even though we may not delete, we should give user option to still run code
714             if(not $self->{user_error} and $self->should_delete) {
715             $self->_delete;
716             &{$self->post_delete}($self);
717             }
718             else { $self->_generate_output }
719             }
720             else {
721             $self->_set_status(405);
722             }
723              
724             $self->print_response if $print;
725             $self->_clear;
726             }
727              
728             sub generate_output {
729             my $self = shift;
730             my ($arr_ref) = @_;
731              
732             #necessary if we are going to use _url_base via thumbnail_url_base and upload_url_base
733             $self->_set_uri;
734              
735             my @arr;
736             for(@$arr_ref) {
737             my %h;
738             die "Must provide a filename in generate_output" unless exists $_->{filename};
739             die "Must provide a size in generate_output" unless exists $_->{size};
740             $self->{is_image} = $_->{image} eq 'y' ? 1 : 0;
741             $h{size} = $_->{size};
742             $h{error} = $_->{error};
743            
744             if(exists $_->{'name'}) {
745             $h{name} = $_->{name}
746             }
747             else {
748             $h{name} = $_->{filename};
749             }
750              
751             if($_->{filename}) {
752             $self->filename($_->{filename});
753             }
754              
755             if(exists $_->{thumbnail_filename}) {
756             $self->thumbnail_filename($_->{thumbnail_filename});
757             }
758             else {
759             my $no_ext = $self->_no_ext;
760             $self->thumbnail_filename($self->thumbnail_prefix . $no_ext . $self->thumbnail_postfix . '.' . $self->thumbnail_format);
761             }
762              
763             $self->_set_urls;
764             $h{url} = $_->{url} eq '' ? $self->url : $_->{url};
765             $h{thumbnailUrl} = $_->{thumbnailUrl} eq '' ? $self->thumbnail_url : $_->{thumbnailUrl};
766              
767             $h{deleteUrl} = $_->{'deleteUrl'} eq '' ? $self->_delete_url($_->{delete_params}) : $_->{'deleteUrl'};
768             $h{deleteType} = 'DELETE';
769             push @arr, \%h;
770              
771             #reset for the next time around
772             $self->delete_url('');
773             }
774              
775             #they should provide image=y or image=n if image
776             my $json = JSON::XS->new->ascii->pretty->allow_nonref;
777             $self->{output} = $json->encode({files => \@arr});
778             }
779              
780             sub _no_ext {
781             my $self = shift;
782             $self->filename($_->{filename});
783             my ($no_ext) = $self->filename =~ qr/(.*)\.(.*)/;
784             return $no_ext;
785             }
786              
787             #PRE/POST METHODS
788             sub pre_delete {
789             my $self = shift;
790            
791             if (@_) {
792             $self->{pre_delete} = shift;
793             }
794            
795             return $self->{pre_delete};
796             }
797              
798             sub post_delete {
799             my $self = shift;
800            
801             if (@_) {
802             $self->{post_delete} = shift;
803             }
804            
805             return $self->{post_delete};
806             }
807              
808             sub pre_post {
809             my $self = shift;
810            
811             if (@_) {
812             $self->{pre_post} = shift;
813             }
814            
815             return $self->{pre_post};
816             }
817              
818             sub post_post {
819             my $self = shift;
820            
821             if (@_) {
822             $self->{post_post} = shift;
823             }
824            
825             return $self->{post_post};
826             }
827              
828             sub pre_get {
829             my $self = shift;
830            
831             if (@_) {
832             $self->{pre_get} = shift;
833             }
834            
835             return $self->{pre_get};
836             }
837              
838             sub post_get {
839             my $self = shift;
840            
841             if (@_) {
842             $self->{post_get} = shift;
843             }
844            
845             return $self->{post_get};
846             }
847              
848             sub _clear {
849             my $self = shift;
850              
851             #clear cgi object so we get a new one for new request
852             $self->{cgi} = undef;
853             $self->{handle} = undef;
854             $self->{tmp_filename} = undef;
855             $self->{upload} = undef;
856             $self->{fh} = undef;
857             $self->{file_size} = undef;
858             $self->{error} = undef;
859             $self->{file_type} = undef;
860             $self->{is_image} = 0;
861             $self->{width} = undef;
862             $self->{height} = undef;
863             $self->{num_files_in_dir} = undef;
864             $self->{output} = undef;
865             $self->{client_filename} = undef;
866             $self->{tmp_thumb_path} = undef;
867             $self->{tmp_file_path} = undef;
868             $self->{user_error} = undef;
869             }
870              
871             sub _post {
872             my $self = shift;
873              
874             if($self->_prepare_file_attrs and $self->_validate_file) {
875             if($self->is_image) {
876             $self->_create_thumbnail;
877             $self->_create_tmp_image
878             }
879             $self->_save;
880             }
881              
882             #delete temporary files
883             if($self->is_image) {
884             unlink ($self->{tmp_thumb_path}, $self->{tmp_file_path});
885             }
886              
887             #generate json output
888             $self->_generate_output;
889             }
890              
891             sub _generate_output {
892             my $self = shift;
893            
894             my $method = $self->_get_request_method;
895             my $obj;
896              
897             if($method eq 'POST') {
898             my %hash;
899             unless($self->{user_error}) {
900             $hash{'url'} = $self->url;
901             $hash{'thumbnailUrl'} = $self->thumbnail_url;
902             $hash{'deleteUrl'} = $self->_delete_url;
903             $hash{'deleteType'} = 'DELETE';
904             $hash{error} = $self->_generate_error;
905             }
906             else {
907             $self->_prepare_file_basics;
908             $hash{error} = $self->{user_error};
909             }
910              
911             $hash{'name'} = $self->show_client_filename ? $self->client_filename . "" : $self->filename;
912             $hash{'size'} = $self->{file_size};
913             $obj->{files} = [\%hash];
914             }
915             elsif($method eq 'DELETE') {
916             unless($self->{user_error}) {
917             $obj->{$self->_get_param('filename')} = JSON::true;
918             }
919             else {
920             $obj->{error} = $self->{user_error};
921             }
922             }
923              
924             my $json = JSON::XS->new->ascii->pretty->allow_nonref;
925             $self->{output} = $json->encode($obj);
926             }
927              
928             sub _delete {
929             my $self = shift;
930              
931             my $filename = $self->_get_param('filename');
932             my $thumbnail_filename = $self->_get_param('thumbnail_filename');
933             my $image_yn = $self->_get_param('image');
934              
935             if(@{$self->scp}) {
936             for(@{$self->scp}) {
937            
938             my $ssh2 = $self->_auth_user($_);
939             $_->{thumbnail_upload_dir} = $_->{upload_dir} if $_->{thumbnail_upload_dir} eq '';
940              
941             my $sftp = $ssh2->sftp;
942             $sftp->unlink($_->{upload_dir} . '/' . $filename);
943             $sftp->unlink($_->{thumbnail_upload_dir} . '/' . $thumbnail_filename) if $image_yn eq 'y';
944             }
945             }
946             else {
947             my $no_ext = $self->_no_ext;
948             unlink $self->upload_dir . '/' . $filename;
949             unlink($self->thumbnail_upload_dir . '/' . $thumbnail_filename) if $image_yn eq 'y';
950             }
951              
952             $self->_generate_output;
953             }
954              
955             sub _get_param {
956             my $self = shift;
957             my ($param) = @_;
958              
959             if(defined $self->ctx) {
960             return $self->ctx->req->params->{$param};
961             }
962             else {
963             return $self->cgi->param($param);
964             }
965             }
966              
967             sub _delete_url {
968             my $self = shift;
969             return if $self->delete_url ne '';
970             my ($delete_params) = @_;
971              
972             my $url = $self->script_url;
973             my $uri = $self->{uri}->clone;
974              
975             my $image_yn = $self->is_image ? 'y' : 'n';
976              
977             unless(defined $delete_params and scalar(@$delete_params)) {
978             $delete_params = [];
979             }
980              
981             push @$delete_params, @{$self->delete_params} if @{$self->delete_params};
982             push @$delete_params, ('filename',$self->filename,'image',$image_yn);
983             push @$delete_params, ('thumbnail_filename',$self->thumbnail_filename) if $self->is_image;
984              
985             $uri->query_form($delete_params);
986              
987             $self->delete_url($uri->as_string);
988              
989             return $self->delete_url;
990             }
991              
992             sub _script_url {
993             my $self = shift;
994              
995             if(defined $self->ctx) {
996             return $self->ctx->request->uri;
997             }
998             else {
999             return $ENV{'SCRIPT_URI'};
1000             }
1001             }
1002              
1003             sub _prepare_file_attrs {
1004             my $self = shift;
1005              
1006             #ORDER MATTERS
1007             return unless $self->_prepare_file_basics;
1008             $self->_set_tmp_filename;
1009             $self->_set_file_type;
1010             $self->_set_is_image;
1011             $self->_set_filename;
1012             $self->_set_absolute_filenames;
1013             $self->_set_image_magick;
1014             $self->_set_width;
1015             $self->_set_height;
1016             $self->_set_num_files_in_dir;
1017             $self->_set_uri;
1018             $self->_set_urls;
1019              
1020             return 1;
1021             }
1022              
1023             sub _prepare_file_basics {
1024             my ($self) = @_;
1025              
1026             return undef unless $self->_set_upload_obj;
1027             $self->_set_fh;
1028             $self->_set_file_size;
1029             $self->_set_client_filename;
1030              
1031             return 1;
1032             }
1033              
1034             sub _set_urls {
1035             my $self = shift;
1036              
1037             if($self->is_image) {
1038             $self->{thumbnail_url} = $self->thumbnail_url_base . '/' . $self->thumbnail_filename;
1039             }
1040             $self->{url} = $self->upload_url_base . '/' . $self->filename;
1041             }
1042              
1043             sub _set_uri {
1044             my $self = shift;
1045             #if catalyst, use URI already made?
1046             if(defined $self->ctx) {
1047             $self->{uri} = $self->ctx->req->uri;
1048             }
1049             else {
1050             $self->{uri} = URI->new($self->script_url);
1051             }
1052             }
1053              
1054             sub _generate_error {
1055             my $self = shift;
1056             return undef unless defined $self->{error} and @{$self->{error}};
1057              
1058             my $restrictions = join ',', @{$self->{error}->[1]};
1059             return $errors{$self->{error}->[0]} . " Restriction: $restrictions Provided: " . $self->{error}->[2];
1060             }
1061              
1062             sub _validate_file {
1063             my $self = shift;
1064             return undef unless
1065             $self->_validate_max_file_size and
1066             $self->_validate_min_file_size and
1067             $self->_validate_accept_file_types and
1068             $self->_validate_reject_file_types and
1069             $self->_validate_max_width and
1070             $self->_validate_min_width and
1071             $self->_validate_max_height and
1072             $self->_validate_min_height and
1073             $self->_validate_max_number_of_files;
1074              
1075             return 1;
1076             }
1077              
1078             sub _save {
1079             my $self = shift;
1080            
1081             if(@{$self->scp}) {
1082             $self->_save_scp;
1083             }
1084             else {
1085             $self->_save_local;
1086             }
1087             }
1088              
1089             sub _save_scp {
1090             my $self = shift;
1091              
1092             for(@{$self->scp}) {
1093             die "Must provide a host to scp" if $_->{host} eq '';
1094              
1095             $_->{thumbnail_upload_dir} = $_->{upload_dir} if $_->{thumbnail_upload_dir} eq '';
1096              
1097             my $path = $_->{upload_dir} . '/' . $self->filename;
1098             my $thumb_path = $_->{thumbnail_upload_dir} . '/' . $self->thumbnail_filename;
1099              
1100             if(($_->{user} ne '' and $_->{public_key} ne '' and $_->{private_key} ne '') or ($_->{user} ne '' and $_->{password} ne '')) {
1101             my $ssh2 = $self->_auth_user($_);
1102              
1103             #if it is an image, scp both file and thumbnail
1104             if($self->is_image) {
1105             $ssh2->scp_put($self->{tmp_file_path}, $path);
1106             $ssh2->scp_put($self->{tmp_thumb_path}, $thumb_path);
1107             }
1108             else {
1109             $ssh2->scp_put($self->{tmp_filename}, $path);
1110             }
1111              
1112             $ssh2->disconnect;
1113             }
1114             else {
1115             die "Must provide a user and password or user and identity file for connecting to host";
1116             }
1117            
1118             }
1119             }
1120              
1121             sub _auth_user {
1122             my $self = shift;
1123             my ($auth) = @_;
1124              
1125             my $ssh2 = Net::SSH2->new;
1126              
1127             $ssh2->connect($auth->{host}) or die $!;
1128              
1129             #authenticate
1130             if($auth->{user} ne '' and $auth->{public_key} ne '' and $auth->{private_key} ne '') {
1131             $ssh2->auth_publickey($auth->{user},$auth->{public_key},$auth->{private_key});
1132             }
1133             else {
1134             $ssh2->auth_password($auth->{user},$auth->{password});
1135             }
1136              
1137             unless($ssh2->auth_ok) {
1138             die "error authenticating with remote server";
1139             }
1140              
1141             die "upload directory must be provided with scp hash" if $auth->{upload_dir} eq '';
1142              
1143             return $ssh2;
1144             }
1145              
1146             sub _save_local {
1147             my $self = shift;
1148              
1149             #if image
1150             if($self->is_image) {
1151             rename $self->{tmp_file_path}, $self->absolute_filename;
1152             rename $self->{tmp_thumb_path}, $self->absolute_thumbnail_filename;
1153             }
1154             #if non-image with catalyst
1155             elsif(defined $self->ctx) {
1156             $self->{upload}->link_to($self->absolute_filename);
1157             }
1158             #if non-image with regular CGI perl
1159             else {
1160             my $io_handle = $self->{fh}->handle;
1161              
1162             my $buffer;
1163             open (OUTFILE,'>', $self->absolute_filename);
1164             while (my $bytesread = $io_handle->read($buffer,1024)) {
1165             print OUTFILE $buffer;
1166             }
1167              
1168             close OUTFILE;
1169             }
1170             }
1171              
1172             sub _validate_max_file_size {
1173             my $self = shift;
1174             return 1 unless $self->max_file_size;
1175            
1176             if($self->{file_size} > $self->max_file_size) {
1177             $self->{error} = ['_validate_max_file_size',[$self->max_file_size],$self->{file_size}];
1178             return undef;
1179             }
1180             else {
1181             return 1;
1182             }
1183             }
1184              
1185             sub _validate_min_file_size {
1186             my $self = shift;
1187             return 1 unless $self->min_file_size;
1188            
1189             if($self->{file_size} < $self->min_file_size) {
1190             $self->{error} = ['_validate_min_file_size',[$self->min_file_size],$self->{file_size}];
1191             return undef;
1192             }
1193             else {
1194             return 1;
1195             }
1196             }
1197              
1198             sub _validate_accept_file_types {
1199             my $self = shift;
1200              
1201             #if accept_file_types is empty, we except all types
1202             #so return true
1203             return 1 unless @{$self->accept_file_types};
1204              
1205             if(grep { $_ eq $self->{file_type} } @{$self->{accept_file_types}}) {
1206             return 1;
1207             }
1208             else {
1209             my $types = join ",", @{$self->accept_file_types};
1210             $self->{error} = ['_validate_accept_file_types',[$types],$self->{file_type}];
1211             return undef;
1212             }
1213             }
1214              
1215             sub _validate_reject_file_types {
1216             my $self = shift;
1217              
1218             #if reject_file_types is empty, we except all types
1219             #so return true
1220             return 1 unless @{$self->reject_file_types};
1221              
1222             unless(grep { $_ eq $self->{file_type} } @{$self->{reject_file_types}}) {
1223             return 1;
1224             }
1225             else {
1226             my $types = join ",", @{$self->reject_file_types};
1227             $self->{error} = ['_validate_reject_file_types',[$types],$self->{file_type}];
1228             return undef;
1229             }
1230             }
1231              
1232             sub _validate_max_width {
1233             my $self = shift;
1234             return 1 unless $self->is_image;
1235              
1236             #if set to undef, there's no max_width
1237             return 1 unless $self->max_width;
1238              
1239             if($self->{width} > $self->max_width) {
1240             $self->{error} = ['_validate_max_width',[$self->max_width],$self->{width}];
1241             return undef;
1242             }
1243             else {
1244             return 1;
1245             }
1246             }
1247              
1248             sub _validate_min_width {
1249             my $self = shift;
1250             return 1 unless $self->is_image;
1251              
1252             #if set to undef, there's no min_width
1253             return 1 unless $self->min_width;
1254              
1255             if($self->{width} < $self->min_width) {
1256             $self->{error} = ['_validate_min_width',[$self->min_width],$self->{width}];
1257             return undef;
1258             }
1259             else {
1260             return 1;
1261             }
1262             }
1263              
1264             sub _validate_max_height {
1265             my $self = shift;
1266             return 1 unless $self->is_image;
1267              
1268             #if set to undef, there's no max_height
1269             return 1 unless $self->max_height;
1270              
1271             if($self->{height} > $self->max_height) {
1272             $self->{error} = ['_validate_max_height',[$self->max_height],$self->{height}];
1273             return undef;
1274             }
1275             else {
1276             return 1;
1277             }
1278             }
1279              
1280             sub _validate_min_height {
1281             my $self = shift;
1282             return 1 unless $self->is_image;
1283              
1284             #if set to undef, there's no max_height
1285             return 1 unless $self->min_height;
1286              
1287             if($self->{height} < $self->min_height) {
1288             $self->{error} = ['_validate_min_height',[$self->min_height],$self->{height}];
1289             return undef;
1290             }
1291             else {
1292             return 1;
1293             }
1294             }
1295              
1296             sub _validate_max_number_of_files {
1297             my $self = shift;
1298             return 1 unless $self->max_number_of_files;
1299              
1300             if($self->{num_files_in_dir} > $self->max_number_of_files) {
1301             $self->{error} = ['_validate_max_number_of_files',[$self->max_number_of_files],$self->{num_files_in_dir}];
1302             return undef;
1303             }
1304             else {
1305             return 1;
1306             }
1307             }
1308              
1309             sub _set_file_size {
1310             my $self = shift;
1311              
1312             if(defined $self->ctx) {
1313             $self->{file_size} = $self->{upload}->size;
1314             }
1315             else {
1316             $self->{file_size} = -s $self->{upload};
1317             }
1318              
1319             return $self->{file_size};
1320             }
1321              
1322             sub _set_client_filename {
1323             my $self = shift;
1324             return if defined $self->client_filename;
1325              
1326             if(defined $self->ctx) {
1327             $self->client_filename($self->{upload}->filename);
1328             }
1329             else {
1330             $self->client_filename($self->cgi->param($self->field_name));
1331             }
1332              
1333             return $self->client_filename;
1334             }
1335              
1336             sub _set_filename {
1337             my $self = shift;
1338             return if defined $self->filename;
1339              
1340             if($self->use_client_filename) {
1341             $self->filename($self->client_filename);
1342             }
1343             else {
1344             my $filename = Data::GUID->new->as_string . $self->filename_salt;
1345             $self->thumbnail_filename($self->thumbnail_prefix . $filename . $self->thumbnail_postfix . '.' . $self->thumbnail_format) unless $self->thumbnail_filename;
1346              
1347             if($self->is_image) {
1348             $filename .= '.' . $self->format;
1349             }
1350             else {
1351             #add extension if present
1352             if($self->client_filename =~ qr/.*\.(.*)/) {
1353             $filename .= '.' . $1;
1354             }
1355             }
1356             $self->filename($filename) unless $self->filename;
1357             }
1358              
1359             return $self->filename;
1360             }
1361              
1362             sub _set_absolute_filenames {
1363             my $self = shift;
1364              
1365             $self->absolute_filename($self->upload_dir . '/' . $self->filename) unless $self->absolute_filename;
1366             $self->absolute_thumbnail_filename($self->thumbnail_upload_dir . '/' . $self->thumbnail_filename) unless $self->absolute_thumbnail_filename;
1367             }
1368              
1369             sub _set_file_type {
1370             my $self = shift;
1371              
1372             if(defined $self->ctx) {
1373             $self->{file_type} = $self->{upload}->type;
1374             }
1375             else {
1376             $self->{file_type} = $self->cgi->uploadInfo($self->client_filename)->{'Content-Type'};
1377             }
1378              
1379             return $self->{file_type};
1380             }
1381              
1382             sub _set_is_image {
1383             my $self = shift;
1384              
1385             if($self->{file_type} eq 'image/jpeg' or $self->{file_type} eq 'image/jpg' or $self->{file_type} eq 'image/png' or $self->{file_type} eq 'image/gif') {
1386             $self->{is_image} = 1;
1387             }
1388             else {
1389             $self->{is_image} = 0;
1390             }
1391              
1392             return $self->is_image;
1393             }
1394              
1395             sub _set_image_magick {
1396             my $self = shift;
1397             return unless $self->is_image;
1398              
1399             #if used in persistent setting, don't recreate object
1400             $self->{image_magick} = Image::Magick->new unless defined $self->{image_magick};
1401              
1402             $self->{image_magick}->Read(file => $self->{fh});
1403              
1404             return $self->{image_magick};
1405             }
1406              
1407             sub _set_width {
1408             my $self = shift;
1409             return unless $self->is_image;
1410              
1411             $self->{width} = $self->{image_magick}->Get('width');
1412             }
1413              
1414             sub _set_height {
1415             my $self = shift;
1416             return unless $self->is_image;
1417              
1418             $self->{height} = $self->{image_magick}->Get('height');
1419             }
1420              
1421             sub _set_tmp_filename {
1422             my $self = shift;
1423              
1424             my $tmp_filename;
1425             if(defined $self->ctx) {
1426             $self->{tmp_filename} = $self->{upload}->tempname;
1427             }
1428             else {
1429             $self->{tmp_filename} = $self->cgi->tmpFileName($self->client_filename);
1430             }
1431             }
1432              
1433             sub _set_upload_obj {
1434             my $self = shift;
1435              
1436             if(defined $self->ctx) {
1437             $self->{upload} = $self->ctx->request->upload($self->field_name);
1438             }
1439             else {
1440             $self->{upload} = $self->cgi->upload($self->field_name);
1441             }
1442              
1443             return defined $self->{upload};
1444             }
1445              
1446             sub _set_fh {
1447             my $self = shift;
1448              
1449             if(defined $self->ctx) {
1450             $self->{fh} = $self->{upload}->fh;
1451             }
1452             else {
1453             $self->{fh} = $self->{upload};
1454             }
1455              
1456             return $self->{fh};
1457             }
1458              
1459             sub _set_num_files_in_dir {
1460             my $self = shift;
1461             return unless $self->max_number_of_files;
1462              
1463             #DO SCP VERSION
1464             if(@{$self->{scp}}) {
1465             my $max = 0;
1466             for(@{$self->{scp}}) {
1467             my $ssh2 = $self->_auth_user($_);
1468             my $chan = $ssh2->channel();
1469             $chan->exec('ls -rt ' . $_->{upload_dir} . ' | wc -l');
1470             my $buffer;
1471             $chan->read($buffer,1024);
1472             ($self->{num_files_in_dir}) = $buffer =~ qr/(\d+)/;
1473             $max = $self->{num_files_in_dir} if $self->{num_files_in_dir} > $max;
1474             }
1475            
1476             #set to maximum of hosts because we know if one's over that's too many
1477             $self->{num_files_in_dir} = $max;
1478             }
1479             else {
1480             my $dir = $self->upload_dir;
1481             my @files = <$dir/*>;
1482             $self->{num_files_in_dir} = @files;
1483             }
1484              
1485             return $self->{num_files_in_dir};
1486             }
1487              
1488             sub _get_request_method {
1489             my $self = shift;
1490            
1491             my $method = '';
1492             if(defined $self->ctx) {
1493             $method = $self->ctx->req->method;
1494             }
1495             else {
1496             $method = $self->cgi->request_method;
1497             }
1498              
1499             return $method;
1500             }
1501              
1502             sub _set_status {
1503             my $self = shift;
1504             my ($response) = @_;
1505              
1506             if(defined $self->ctx) {
1507             $self->ctx->response->status($response);
1508             }
1509             else {
1510             print $self->cgi->header(-status=>$response);
1511             }
1512             }
1513              
1514             sub _set_header {
1515             my $self = shift;
1516             my ($key,$val) = @_;
1517              
1518             if(defined $self->ctx) {
1519             $self->ctx->response->header($key => $val);
1520             }
1521             else {
1522             print $self->cgi->header($key,$val);
1523             }
1524             }
1525              
1526             sub _create_thumbnail {
1527             my $self = shift;
1528            
1529             my $im = $self->{image_magick}->Clone;
1530            
1531             #thumb is added at beginning of tmp_thumb_path as to not clash with the original image file path
1532             my $output = $self->{tmp_thumb_path} = $self->tmp_dir . '/thumb_' . $self->thumbnail_filename;
1533             my $width = $self->thumbnail_width;
1534             my $height = $self->thumbnail_height;
1535            
1536             my $density = $self->thumbnail_density || $width . "x" . $height;
1537             my $quality = $self->thumbnail_quality;
1538             my $format = $self->thumbnail_format;
1539            
1540             # source image dimensions
1541             my ($o_width, $o_height) = $im->Get('width','height');
1542            
1543             # calculate image dimensions required to fit onto thumbnail
1544             my ($t_width, $t_height, $ratio);
1545             # wider than tall (seems to work...) needs testing
1546             if( $o_width > $o_height ){
1547             $ratio = $o_width / $o_height;
1548             $t_width = $width;
1549             $t_height = $width / $ratio;
1550            
1551             # still won't fit, find the smallest size.
1552             while($t_height > $height){
1553             $t_height -= $ratio;
1554             $t_width -= 1;
1555             }
1556             }
1557             # taller than wide
1558             elsif( $o_height > $o_width ){
1559             $ratio = $o_height / $o_width;
1560             $t_height = $height;
1561             $t_width = $height / $ratio;
1562            
1563             # still won't fit, find the smallest size.
1564             while($t_width > $width){
1565             $t_width -= $ratio;
1566             $t_height -= 1;
1567             }
1568             }
1569             # square (fixed suggested by Philip Munt phil@savvyshopper.net.au)
1570             elsif( $o_width == $o_height){
1571             $ratio = 1;
1572             $t_height = $width;
1573             $t_width = $width;
1574             while (($t_width > $width) or ($t_height > $height)){
1575             $t_width -= 1;
1576             $t_height -= 1;
1577             }
1578             }
1579              
1580             # Create thumbnail
1581             if( defined $im ){
1582             $im->Resize( width => $t_width, height => $t_height );
1583             $im->Set( quality => $quality );
1584             $im->Set( density => $density );
1585            
1586             $self->final_width($t_width);
1587             $self->final_height($t_height);
1588              
1589             $im->Write("$format:$output");
1590             }
1591             }
1592              
1593             sub _create_tmp_image {
1594             my $self = shift;
1595             my $im = $self->{image_magick};
1596            
1597             #main_ is added as to not clash with thumbnail tmp path if thumbnail_prefix = '' and they have the same name
1598             my $output = $self->{tmp_file_path} = $self->tmp_dir . '/main_' . $self->filename;
1599             my $quality = $self->thumbnail_quality;
1600             my $format = $self->thumbnail_format;
1601              
1602             if( defined $im ){
1603             $im->Set( quality => $quality );
1604            
1605             $im->Write("$format:$output");
1606              
1607             $self->final_width($im->Get('width'));
1608             $self->final_height($im->Get('height'));
1609             }
1610             }
1611              
1612             #sub _save_cloud {
1613             # my $self = shift;
1614             # my $io_handle = $self->{fh}->handle;
1615             #
1616             # #IF IS IMAGE, MUST UPLOAD BOTH IMAGES
1617             #
1618             # my $s_contents;
1619             # while (my $bytesread = $io_handle->read($buffer,1024)) {
1620             # print OUTFILE $buffer;
1621             ## }
1622             #
1623             #
1624             ## while()
1625             # {
1626             # $s_contents .= $_;
1627             ## }
1628             #
1629             ## ### we will call this resource whatever comes after the last /
1630             # my $s_resourceName;
1631             #
1632             ## if($param->{'path'} =~ /^.*\/(.*)$/)
1633             # {
1634             # $s_resourceName = $1;
1635             ## }
1636             # else
1637             # {
1638             # return('fail', "could not parse path: $param->{'path'}");
1639             ## }
1640             #
1641             # ### should we pass these vars ... or look them up?
1642             # my $s_user = '';
1643             # my $s_key = '';
1644             ## my $s_cdn_uri ='';
1645             #
1646             # my $ua = LWP::UserAgent->new;
1647             # my $req = HTTP::Request->new(GET => 'https://auth.api.rackspacecloud.com/v1.0');
1648             ## $req->header('X-Auth-User' => $s_user);
1649             # $req->header('X-Auth-Key' => $s_key);
1650             #
1651             ## my $res = $ua->request($req);
1652             #
1653             # if ($res->is_success)
1654             ## {
1655             # my $s_url = $res->header('X-Storage-Url') . "/container/" . $s_resourceName;
1656             #
1657             ## my $reqPUT = HTTP::Request->new(PUT => $s_url);
1658             # $reqPUT->header('X-Auth-Token' => $res->header('X-Auth-Token'));
1659             #
1660             ## $reqPUT->content( $s_contents );
1661             #
1662             # my $resPUT = $ua->request($reqPUT);
1663             ##
1664             # if($resPUT->is_success)
1665             # {
1666             ## my $s_returnURI = $s_cdn_uri . "/" . $s_resourceName;
1667             # return('pass','passed afaict', $s_returnURI);
1668             # }
1669             ## else
1670             # {
1671             # my $s_temp = $resPUT->as_string;
1672             # $s_temp =~ s/'/\\'/g;
1673             ## return('fail',"PUT failed with response:$s_temp")
1674             # }
1675             # }
1676             ## else
1677             # {
1678             # my $s_temp = $res->as_string;
1679             ## $s_temp =~ s/'/\\'/g;
1680             # return('fail',"failed with response:$s_temp")
1681             # }
1682             ## }
1683             # else
1684             # {
1685             ## return("fail","sorry no file found at $param->{'path'}");
1686             # }
1687             #}
1688             #
1689             ##sub _delete_cloud {
1690             # my $self = shift;
1691             # my $request = HTTP::Request->new( 'DELETE', $self->_url,
1692             #Q [ 'X-Auth-Token' => $self->cloudfiles->token ] );
1693             # my $response = $self->cloudfiles->_request($request);
1694             # confess 'Object ' . $self->name . ' not found' if $response->code == 404;
1695             # confess 'Unknown error' if $response->code != 204;
1696             #}
1697              
1698             # Preloaded methods go here.
1699              
1700             1;
1701             __END__