libterm-clui-perl 1.68-1 / usr / share / perl5 / Term / Clui / FileSelect.pm

# Term/Clui/FileSelect.pm
#########################################################################
#        This Perl module is Copyright (c) 2002, Peter J Billam         #
#               c/o P J B Computing, www.pjb.com.au                     #
#                                                                       #
#     This module is free software; you can redistribute it and/or      #
#            modify it under the same terms as Perl itself.             #
#########################################################################

package Term::Clui::FileSelect;
$VERSION = '1.68';
import Term::Clui(':DEFAULT','back_up');
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(select_file);
@EXPORT_OK = qw();

no strict; no warnings;

my $home = $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[$[+7];
$home =~ s#([^/])$#$1/#;

sub select_file {   my %option = @_;
	if (!defined $option{'-Path'}) { $option{'-Path'}=$option{'-initialdir'}; }
	if (!defined $option{'-FPat'}) { $option{'-FPat'}=$option{'-filter'}; }
	if (!defined $option{'-ShowAll'}) {
		$option{'-ShowAll'} = $option{'-dotfiles'};
	}
	if ($option{'-Directory'}) { $option{'-Chdir'}=1; $option{'-SelDir'}=1; }
	my $multichoice = 0;
	if (wantarray && !$option{'-Chdir'} && !$option{'-Create'}) {
		$option{'-DisableShowAll'} = 1;
		$multichoice = 1;
	} elsif (!defined $option{'-Chdir'}) {
		$option{'-Chdir'} = 1;
	}

	if ($option{'-Path'} && -d $option{'-Path'}) {
		$dir=$option{'-Path'};
		if ($dir =~ m#[^/]$#) { $dir .= '/'; }
	} else {
		$dir = $home;
	}
	if ($option{'-TopDir'}) {
		if (!-d $option{'-TopDir'}) { delete $option{'-TopDir'};
		} elsif ($option{'-TopDir'} =~ m#[^/]$#) { $option{'-TopDir'} .= '/';
		}
		if (index $dir, $option{'-TopDir'}) { $dir = $option{'-TopDir'}; }
	}

	my ($new, $file, @allfiles, @files, @dirs, @pre, @post, %seen, $isnew);
	my @dotfiles;

	while () {
		if (! opendir (D, $dir)) { warn "can't opendir $dir: $!\n"; return 0; }
		if ($option{'-SelDir'}) { @pre = ('./'); } else { @pre = (); }
		@post = ();
		@allfiles = sort grep(!/^\.\.?$/, readdir D); closedir D;
		@dotfiles = grep(/^\./, @allfiles);
		if ($option{'-ShowAll'}) {
			if (@dotfiles && !$option{'-DisableShowAll'}) {
				@post='Hide DotFiles';
			}
		} else {
			@allfiles = grep(!/^\./, @allfiles);
			if (@dotfiles && !$option{'-DisableShowAll'}) {
				@post='Show DotFiles';
			}
		}
		# split @allfiles into @files and @dirs for option processing ...
		@dirs  = grep(-d "$dir/$_" && -r "$dir/$_", @allfiles);
		if ($option{'-Directory'}) {
			@files = ();
		} elsif ($option{'-FPat'}) {
			@files = grep(!-d $_, glob("$dir/$option{'-FPat'}"));
			my $length = $[ + 1 + length $dir;
			foreach (@files) { $_ = substr $_, $length; }
		} else {
			@files = grep(!-d "$dir/$_", @allfiles);
		}
		if ($option{'-Chdir'}) {
			foreach (@dirs) { s#$#/#; }
			if ($option{'-TopDir'}) {
				my $up = $dir; $up =~ s#[^/]+/?$##;   # find parent directory
				if (-1 < index $up, $option{'-TopDir'}) { unshift @pre, '../'; }
				# must check for symlinks to outside the TopDir ...
			} else { unshift @pre, '../';
			}
		} elsif (!$option{'-SelDir'}) {
			@dirs = ();
		}
		if ($option{'-Create'})     { unshift @post, 'Create New File'; }
		if ($option{'-TextFile'})   { @files = grep(-T "$dir/$_", @files); }
		if ($option{'-Owned'})      { @files = grep(-o "$dir/$_", @files); }
		if ($option{'-Executable'}) { @files = grep(-x "$dir/$_", @files); }
		if ($option{'-Writeable'})  { @files = grep(-w "$dir/$_", @files); }
		if ($option{'-Readable'})   { @files = grep(-r "$dir/$_", @files); }
		@allfiles = (@pre, (sort @dirs,@files), @post); # reconstitute @allfiles

		my $title;
		if ($option{'-Title'}) { $title = "$option{'-Title'} in $dir"
		} else { $title = "in directory $dir ?";
		}
		if ($option{'-File'}) { &set_default($title, $option{'-File'}) }
		$Term::Clui::SpeakMode{'dot'} = 1;
		if ($multichoice) {
			my @new = &choose ($title, @allfiles);
			$Term::Clui::SpeakMode{'dot'} = 0;
			return () unless @new;
			foreach (@new) { $_="$dir$_"; }
			return @new;
		}
		$new = &choose ($title, @allfiles);
		$Term::Clui::SpeakMode{'dot'} = 0;

		if ($option{'-ShowAll'} && $new eq 'Hide DotFiles') {
			delete $option{'-ShowAll'}; redo;
		} elsif (!$option{'-ShowAll'} && $new eq 'Show DotFiles') {
			$option{'-ShowAll'} = 1; redo;
		}
		if ($new eq "Create New File") {
			$new = &ask ("new file name ?");  # validating this is a chore ...
			if (! $new) { next; }
			if ($new =~ m#^/#) { $file = $new; } else { $file = "$dir$new"; }
			$file =~ s#/+#/#g;  # simplify //// down to /
			while ($file =~ m#./\.\./#) { $file =~ s#[^/]*/\.\./##; }  # zap /../
			$file =~ s#/[^/]*/\.\.$##;  # and /.. at end
			if ($option{'-TopDir'}) {  # check against escape from TopDir
				if (index $file, $option{'-TopDir'}) {
					$dir = $option{'-TopDir'}; next;
				}
			}
			if (-d $file) {  # pre-existing directory ?
				if ($option{'-SelDir'}) { return $file;
				} else {
					$dir=$file; if ($dir =~ m#[^/]$#) { $dir.='/'; } next;
				}
			}
			$file =~ m#^(.*/)([^/]+)$#;
			if (-e $file) { $dir = $1; $option{'-File'} = $2; next; } # exists ?
			# must check for creatability (e.g. dir exists and is writeable)
			if (-d $1 && -w $1) { return $file; }
			if (!-d $1) { &sorry ("directory $1 does not exist."); next; }
			&sorry ("directory $1 is not writeable."); next;
		}
		return undef unless $new;
		if ($new eq './' && $option{'-SelDir'}) { return $dir; }
		if ($new =~ m#^/#) { $file = $new; # abs filename
		} else { $file = "$dir$new";       # rel filename (slash always at end)
		}
		if ($new eq '../') { $dir =~ s#[^/]+/?$##; &back_up(); next;
		} elsif ($new eq './') {
			if ($option{'-SelDir'}) { return $dir; } $file = $dir;
		} elsif ($file =~ m#/$#) { $dir = $file; &back_up(); next;
		} elsif (-f $file) { return $file;
		}
	}
}
1;

__END__

=pod

=head1 NAME

Term::Clui::FileSelect - Perl module to ask the user to select a file.

=head1 SYNOPSIS

 use Term::Clui;
 use Term::Clui::FileSelect;
 $file = &select_file(-Readable=>1, -TopDir=>"/home", -FPat=>"*.html");
 @files = &select_file(-Chdir=>0, -Path=>$ENV{PWD}, -FPat=>"*.mp3");
 chdir &select_file(-Directory=>1, -Path=>$ENV{PWD});

=head1 DESCRIPTION

This module asks the user to select a file from the filesystem.
It uses the Command-line user-interface Term::Clui to dialogue with the user.
It offers I<Rescan> and I<ShowAll> buttons.
To ease the re-learning burden for the programmer,
the options are modelled on those of Tk::FileDialog
and of Tk::SimpleFileSelect,
but various new options are introduced, namely I<-TopDir>, I<-TextFile>,
I<-Readable>, I<-Writeable>, I<-Executable>, I<-Owned> and I<-Directory>

Multiple choice is possible in a limited circumstance;
when I<file_select> is invoked in a list context, with -Chdir=>0
and without -Create.  It is currently not possible
to select multiple files lying in different directories.

=head1 SUBROUTINES

=over 3

=item I<select_file>( %options );

=back

=head1 OPTIONS

=over 3

=item I<-Chdir>

Enable the user to change directories. The default is 1.
If it is set to 0, and I<select_file> is invoked in a list context,
and I<-Create> is not set, then the user can select multiple files.

=item I<-Create>

Enable the user to specify a file that does not exist. The default is 0.

=item I<-ShowAll> or I<-dotfiles>

Determines whether hidden files (.*) are displayed.  The default is 0.

=item I<-DisableShowAll>

Disables the ability of the user to change the
status of the ShowAll flag. The default is 0
(i.e. the user is by default allowed to change the status).

=item I<-SelDir>

If True, enables selection of a directory rather than a file.
The default is 0.
To I<enforce> selection of a directory, use the I<-Directory> option.

=item I<-FPat> or I<-filter>

Sets the default file selection pattern, in glob format, e.g. I<*.html>.
Only files matching this pattern will be displayed.
If you want multiple patterns, you can use formats like
I<*.[ch]> or
I<{*.cgi,*.pl}> - see I<File::Glob> for more details.
The default is "*".

=item I<-File>

The file selected, or the default file.
The default default is whatever the user selected last time in this directory.

=item I<-Path> or I<-initialdir>

The path of the selected file, or the initial path.
The default is $ENV{HOME}.

=item I<-Title>

The Title of the dialog box.
If I<-Title> is specified,
then Clui::FileSelect dynamically appends "in I</where/ever>" to it.
If I<-Title> is not specified,
Clui::FileSelect displays "in directory I</where/ever>".

=item I<-TopDir>

Restricts the user to remain within a directory or its subdirectories.
The default is "/".
This option, and the following, are not offered by Tk::FileDialog.

=item I<-TextFile>

Only text files will be displayed. The default is 0.

=item I<-Readable>

Only readable files will be displayed. The default is 0.

=item I<-Writeable>

Only writeable files will be displayed. The default is 0.

=item I<-Executable>

Only executable files will be displayed.
The default is 0.

=item I<-Owned>

Only files owned by the current user will be displayed.
This is useful if the user is being asked to choose a file for a I<chmod>
or I<chgrp> operation, for example.
The default is 0.

=item I<-Directory>

Only directories will be displayed.
The default is 0.

=back

=head1 BUGS

Three problem filenames will, if present in your file-system, cause confusion.
They are I<Create New File>, I<Show DotFiles> and I<Hide DotFiles>

=head1 AUTHOR

Peter J Billam www.pjb.com.au/comp/contact.html

=head1 CREDITS

Based on an old Perl4 library, I<filemgr.pl>,
with the options modelled after I<Tk::FileDialog> and I<Tk::SimpleFileSelect>.

=head1 SEE ALSO

http://www.pjb.com.au/ ,
http://search.cpan.org/~pjb ,
File::Glob ,
Term::Clui ,
Tk::FileDialog ,
Tk::SimpleFileSelect ,
perl(1) .

=cut