File Coverage

blib/lib/Term/Clui/FileSelect.pm
Criterion Covered Total %
statement 8 156 5.1
branch 0 108 0.0
condition 0 30 0.0
subroutine 3 4 75.0
pod 1 1 100.0
total 12 299 4.0


line stmt bran cond sub pod time code
1             # Term/Clui/FileSelect.pm
2             #########################################################################
3             # This Perl module is Copyright (c) 2002, Peter J Billam #
4             # c/o P J B Computing, www.pjb.com.au #
5             # #
6             # This module is free software; you can redistribute it and/or #
7             # modify it under the same terms as Perl itself. #
8             #########################################################################
9              
10             package Term::Clui::FileSelect;
11             our $VERSION = '1.75';
12             import Term::Clui(':DEFAULT','back_up');
13             require Exporter;
14             @ISA = qw(Exporter);
15             @EXPORT = qw(select_file);
16             @EXPORT_OK = qw();
17              
18 1     1   928 use 5.006;
  1         3  
19 1     1   5 no strict; no warnings;
  1     1   1  
  1         19  
  1         4  
  1         2  
  1         1343  
20              
21             my $home = $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[7];
22             $home =~ s#([^/])$#$1/#;
23              
24 0     0 1   sub select_file { my %option = @_;
25 0 0         if (!defined $option{'-Path'}) { $option{'-Path'}=$option{'-initialdir'}; }
  0            
26 0 0         if (!defined $option{'-FPat'}) { $option{'-FPat'}=$option{'-filter'}; }
  0            
27 0 0         if (!defined $option{'-ShowAll'}) {
28 0           $option{'-ShowAll'} = $option{'-dotfiles'};
29             }
30 0 0         if ($option{'-Directory'}) { $option{'-Chdir'}=1; $option{'-SelDir'}=1; }
  0            
  0            
31 0           my $multichoice = 0;
32 0 0 0       if (wantarray && !$option{'-Chdir'} && !$option{'-Create'}) {
    0 0        
33 0           $option{'-DisableShowAll'} = 1;
34 0           $multichoice = 1;
35             } elsif (!defined $option{'-Chdir'}) {
36 0           $option{'-Chdir'} = 1;
37             }
38              
39 0 0 0       if ($option{'-Path'} && -d $option{'-Path'}) {
40 0           $dir=$option{'-Path'};
41 0 0         if ($dir =~ m#[^/]$#) { $dir .= '/'; }
  0            
42             } else {
43 0           $dir = $home;
44             }
45 0 0         if ($option{'-TopDir'}) {
46 0 0         if (!-d $option{'-TopDir'}) { delete $option{'-TopDir'};
  0 0          
47 0           } elsif ($option{'-TopDir'} =~ m#[^/]$#) { $option{'-TopDir'} .= '/';
48             }
49 0 0         if (index $dir, $option{'-TopDir'}) { $dir = $option{'-TopDir'}; }
  0            
50             }
51              
52 0           my ($new, $file, @allfiles, @files, @dirs, @pre, @post, %seen, $isnew);
53 0           my @dotfiles;
54              
55 0           while () {
56 0 0         if (! opendir (D, $dir)) { warn "can't opendir $dir: $!\n"; return 0; }
  0            
  0            
57 0 0         if ($option{'-SelDir'}) { @pre = ('./'); } else { @pre = (); }
  0            
  0            
58 0           @post = ();
59 0           @allfiles = sort grep(!/^\.\.?$/, readdir D); closedir D;
  0            
60 0           @dotfiles = grep(/^\./, @allfiles);
61 0 0         if ($option{'-ShowAll'}) {
62 0 0 0       if (@dotfiles && !$option{'-DisableShowAll'}) {
63 0           @post='Hide DotFiles';
64             }
65             } else {
66 0           @allfiles = grep(!/^\./, @allfiles);
67 0 0 0       if (@dotfiles && !$option{'-DisableShowAll'}) {
68 0           @post='Show DotFiles';
69             }
70             }
71             # split @allfiles into @files and @dirs for option processing ...
72 0   0       @dirs = grep(-d "$dir/$_" && -r "$dir/$_", @allfiles);
73 0 0         if ($option{'-Directory'}) {
    0          
74 0           @files = ();
75             } elsif ($option{'-FPat'}) {
76 0           @files = grep(!-d $_, glob("$dir/$option{'-FPat'}"));
77 0           my $length = 1 + length $dir;
78 0           foreach (@files) { $_ = substr $_, $length; }
  0            
79             } else {
80 0           @files = grep(!-d "$dir/$_", @allfiles);
81             }
82 0 0         if ($option{'-Chdir'}) {
    0          
83 0           foreach (@dirs) { s#$#/#; }
  0            
84 0 0         if ($option{'-TopDir'}) {
85 0           my $up = $dir; $up =~ s#[^/]+/?$##; # find parent directory
  0            
86 0 0         if (-1 < index $up, $option{'-TopDir'}) { unshift @pre, '../'; }
  0            
87             # must check for symlinks to outside the TopDir ...
88 0           } else { unshift @pre, '../';
89             }
90             } elsif (!$option{'-SelDir'}) {
91 0           @dirs = ();
92             }
93 0 0         if ($option{'-Create'}) { unshift @post, 'Create New File'; }
  0            
94 0 0         if ($option{'-TextFile'}) { @files = grep(-T "$dir/$_", @files); }
  0            
95 0 0         if ($option{'-Owned'}) { @files = grep(-o "$dir/$_", @files); }
  0            
96 0 0         if ($option{'-Executable'}) { @files = grep(-x "$dir/$_", @files); }
  0            
97 0 0         if ($option{'-Writeable'}) { @files = grep(-w "$dir/$_", @files); }
  0            
98 0 0         if ($option{'-Readable'}) { @files = grep(-r "$dir/$_", @files); }
  0            
99 0           @allfiles = (@pre, (sort @dirs,@files), @post); # reconstitute @allfiles
100              
101 0           my $title;
102 0 0         if ($option{'-Title'}) { $title = "$option{'-Title'} in $dir"
  0            
103 0           } else { $title = "in directory $dir ?";
104             }
105 0 0         if ($option{'-File'}) { &set_default($title, $option{'-File'}) }
  0            
106 0           $Term::Clui::SpeakMode{'dot'} = 1;
107 0 0         if ($multichoice) {
108 0           my @new = &choose ($title, @allfiles);
109 0           $Term::Clui::SpeakMode{'dot'} = 0;
110 0 0         return () unless @new;
111 0           foreach (@new) { $_="$dir$_"; }
  0            
112 0           return @new;
113             }
114 0           $new = &choose ($title, @allfiles);
115 0           $Term::Clui::SpeakMode{'dot'} = 0;
116              
117 0 0 0       if ($option{'-ShowAll'} && $new eq 'Hide DotFiles') {
    0 0        
118 0           delete $option{'-ShowAll'}; redo;
  0            
119             } elsif (!$option{'-ShowAll'} && $new eq 'Show DotFiles') {
120 0           $option{'-ShowAll'} = 1; redo;
  0            
121             }
122 0 0         if ($new eq "Create New File") {
123 0           $new = &ask ("new file name ?"); # validating this is a chore ...
124 0 0         if (! $new) { next; }
  0            
125 0 0         if ($new =~ m#^/#) { $file = $new; } else { $file = "$dir$new"; }
  0            
  0            
126 0           $file =~ s#/+#/#g; # simplify //// down to /
127 0           while ($file =~ m#./\.\./#) { $file =~ s#[^/]*/\.\./##; } # zap /../
  0            
128 0           $file =~ s#/[^/]*/\.\.$##; # and /.. at end
129 0 0         if ($option{'-TopDir'}) { # check against escape from TopDir
130 0 0         if (index $file, $option{'-TopDir'}) {
131 0           $dir = $option{'-TopDir'}; next;
  0            
132             }
133             }
134 0 0         if (-d $file) { # pre-existing directory ?
135 0 0         if ($option{'-SelDir'}) { return $file;
  0            
136             } else {
137 0 0         $dir=$file; if ($dir =~ m#[^/]$#) { $dir.='/'; } next;
  0            
  0            
  0            
138             }
139             }
140 0           $file =~ m#^(.*/)([^/]+)$#;
141 0 0         if (-e $file) { $dir = $1; $option{'-File'} = $2; next; } # exists ?
  0            
  0            
  0            
142             # must check for creatability (e.g. dir exists and is writeable)
143 0 0 0       if (-d $1 && -w $1) { return $file; }
  0            
144 0 0         if (!-d $1) { &sorry ("directory $1 does not exist."); next; }
  0            
  0            
145 0           &sorry ("directory $1 is not writeable."); next;
  0            
146             }
147 0 0         return undef unless $new;
148 0 0 0       if ($new eq './' && $option{'-SelDir'}) { return $dir; }
  0            
149 0 0         if ($new =~ m#^/#) { $file = $new; # abs filename
  0            
150 0           } else { $file = "$dir$new"; # rel filename (slash always at end)
151             }
152 0 0         if ($new eq '../') { $dir =~ s#[^/]+/?$##; &back_up(); next;
  0 0          
  0 0          
  0 0          
153             } elsif ($new eq './') {
154 0 0         if ($option{'-SelDir'}) { return $dir; } $file = $dir;
  0            
  0            
155 0           } elsif ($file =~ m#/$#) { $dir = $file; &back_up(); next;
  0            
  0            
156 0           } elsif (-f $file) { return $file;
157             }
158             }
159             }
160             1;
161              
162             __END__