upload results from the CPAN

upload

CGI-FileManager

view release on metacpan or search on metacpan

lib/CGI/FileManager.pm view on Meta::CPAN

use CGI::Application::Plugin::Session;
use CGI::Upload;
use File::Spec;
use File::Basename qw(dirname);
use Data::Dumper qw(Dumper);
use HTML::Template;
#use Fcntl qw(:flock);
#use POSIX qw(strftime);
use File::Copy qw(move);
use Carp qw(cluck croak);

use CGI::FileManager::Templates;
use CGI::FileManager::Auth;
my $cookiename = "cgi-filemanager";


#Standard CGI::Application method
#Setup the Session object and the default HTTP headers

=head2 cgiapp_init

Initialize application (standard CGI::Application)

=cut
sub cgiapp_init {
	my $self = shift;
	CGI::Session->name($cookiename);
	$self->session_config(
#		CGI_SESSION_OPTIONS => [ "driver:File", $self->query, {Directory => "/tmp"}],
		COOKIE_PARAMS       => {
				-expires => '+24h',
				-path    => '/',
#				-domain  => $ENV{HTTP_HOST},
		},
		SEND_COOKIE         => 1,
	);
	
	if ($self->param("TMPL_PATH")) {
		$self->tmpl_path([
			File::Spec->catfile($self->param("TMPL_PATH"), "custom"),
			File::Spec->catfile($self->param("TMPL_PATH"), "factory"),
			]);
	}

	$self->header_props( 
		-expires => '-1d',  
		# I think this this -expires causes some strange behaviour in IE 
		# on the other hand it is needed in Opera to make sure it won't cache pages.
		-charset => "utf-8",
	);
	$self->session_cookie();
}



# modes that can be accessed without a valid session
my @free_modes = qw(login login_process logout about redirect); 
my @restricted_modes = qw(
	list_dir 
	change_dir 
	upload_file 
	delete_file 
	create_directory 
	remove_directory
	rename_form
	rename
	unzip
); 


=head2 setup

Standart CGI::Appication method to setup the list of all run modes and the default run mode 

=cut
sub setup {
	my $self = shift;
	$self->start_mode("list_dir");
	$self->run_modes(\@free_modes);
	$self->run_modes(\@restricted_modes); 
	#$self->run_modes(AUTOLOAD => "autoload");
}

=head2 cgiapp_prerun

Regular CGI::Application method

=cut
sub cgiapp_prerun {
	my $self = shift;
	my $rm = $self->get_current_runmode();

	return if grep {$rm eq $_} @free_modes;

	# Redirect to login, if necessary
	if (not  $self->session->param('loggedin') ) {
		$self->header_type("redirect");
		$self->header_props(-url => "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}?rm=login");
		$self->prerun_mode("redirect");
		return;
	}
}


sub _untaint_path {
	my ($self, $path) = @_;

	return "" if not defined $path;
	return "" if $path =~ /\.\./;
	if ($path =~ m{^([\w./-]+)$}) {
		return $1;
	}

	return "";
}


sub _untaint {
	my ($self, $filename) = @_;

	return if not defined $filename;

lib/CGI/FileManager.pm view on Meta::CPAN



=head2 change_dir

Changes the current directory and then lists the new current directory

=cut
sub change_dir {
	my $self = shift;
	my $q = $self->query;

	my $workdir = $self->_untaint_path($q->param("workdir"));
	my $homedir = $self->session->param("homedir");

	my $dir = $q->param("dir");
	if (not defined $dir) {
		warn "change_dir called without a directory name\n";
		return $self->list_dir;
	}
		
	# check santity of the directory
	# something else, does this directory exist ?
	if ($dir eq "..") {
		# ".." are we at the root ?
		if ($workdir eq "") {
			# do nothing (maybe a beep ?)
			return $self->list_dir;
		} else {
			# shorten the path by one
			$workdir = dirname $workdir;
			$self->header_type("redirect");
			$self->header_props(-url => "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}?rm=list_dir;workdir=$workdir");
			return $self->redirect;
			#Redirect
			return $self->list_dir;
		}
	} else {
		if ($dir =~ /\.\./) {
			warn "change_dir: Two dots ? '$dir'";
			return $self->message("Hmm, two dots in a regular file ? Please contact the administrator");
		}
		if ($dir =~ /^([\w.-]+)$/) {
			$dir = $1;
			$workdir = File::Spec->catfile($workdir, $dir);
			my $path = File::Spec->catfile($homedir, $workdir);
			if (-d $path) {
				$self->header_type("redirect");
				$self->header_props(-url => "http://$ENV{HTTP_HOST}$ENV{SCRIPT_NAME}?rm=list_dir;workdir=$workdir");
				return $self->redirect;
				#$self->session->param(workdir => $workdir);
				#return $self->list_dir;
			} else {
				# after changing directory people might press back ...
				# and then the whole thing can get scread up not only the change directory
				# but if they now delete a file that happen to exist both in the current directory
				# and in its parent (which is currenly shown in the browser) the file will be deleted
				# from the "current directory", I think the only solution is that the user supplies us
				# with full (virtual) path name for every action.
				# This seems to be easy regarding action on existing files as they are all done by clicking
				# on links and the links can contain.
				# Regardin upload/create dir and later create file we have to know where should the thing go
				# - what does the user think is the current working directory. For such operations we can
				# hide the workdir in a hidden field in the form.
				#
				# In either case we have to make sure the full virtual directory is something the user
				# has right to access.
				 
				#my $workdir_name = basename $workdir;
				#if ($workdir_name eq $dir) {
				#	return $self->message("Heuristics !");
				#} else {
					warn "change_dir: Trying to change to invalid directory ? '$workdir'$dir'";
					return $self->message("It does not seem to be a correct directory. Please contact the administrator");
				#}
			}
		} else {
			warn "change_dir: Bad regex, or bad visitor ? '$dir'";
			return $self->message("Hmm, we don't recognize this. Please contact the administrator");
		}
	}
	
	warn "should never got here....";
	return $self->list_dir;
}

=head2 list_dir

Listing the content of a directory

=cut
sub list_dir {
	my $self = shift;
	my $msgs = shift;

	my $q = $self->query;

	my $workdir = $self->_untaint_path($q->param("workdir"));
	my $homedir = $self->session->param("homedir");
	my $path = File::Spec->catfile($homedir, $workdir);


	my $t = $self->load_tmpl(
			"list_dir",
		 	associate => $q,
			loop_context_vars => 1,
	);
	if (opendir my $dh, $path) {
		my @entries = grep {$_ ne "." and $_ ne ".."} readdir $dh;
		if ($workdir ne "" and $workdir ne "/") {
			unshift @entries, "..";
		}
		my @files;
		
		foreach my $f (@entries) {
			my $full = File::Spec->catfile($path, $f);
			push @files, {
				filename    => $f,
				filetype    => $self->_file_type($full),
				subdir      => -d $full,
				zipfile     => ($full =~ /\.zip/i ? 1 : 0),
				filedate    => scalar (localtime((stat($full))[9])),

lib/CGI/FileManager.pm view on Meta::CPAN

		return $self->message("Target file already exist");
	}
	move $old, $new;
	return $self->list_dir;
}

=head2 rename

Rename file

=cut
sub rename {
	my $self = shift;
	my $q = $self->query;

	my $old = $q->param("filename");
	my $old_name = $old = $self->_untaint($old);

	if (not $old) {
		warn "Tainted file name: '" . $q->param("filename") . "'";
		return $self->message("Invalid filename '" . $q->param("filename") . "'. Please contact the system administrator");
	}

	my $homedir = $self->session->param("homedir");
	my $workdir = $self->_untaint_path($q->param("workdir"));

	$old = File::Spec->catfile($homedir, $workdir, $old);
	if (not -e $old) {
		warn "Could not find '$old' for rename";
		return $self->message("File does not seem to exist.");
	}


	my $new = $q->param("newname");
	my $targetdir;
	if ($new eq "..") {
		if ($workdir eq "") {
			warn "Trying to move something above the root: '" . $q->param("filename") . "'";
			return $self->message("This wont work. Please contact the system administrator");
		} else {
			$new = File::Spec->catfile($homedir, dirname($workdir), $old_name);
			return $self->_move($old, $new);
		}
	}

	$new = $self->_untaint($new);

	if (not $new) {
		warn "Tainted file name: '" . $q->param("newname") . "'";
		return $self->message("Invalid filename. '" . $q->param("newname") . "' Please contact the system administrator");
	}

	$new = File::Spec->catfile($homedir, $workdir, $new);
	if (-d $new) {
		$new = File::Spec->catfile($new, $old_name);
	}
	return $self->_move($old, $new);
}


=head2 upload_file

Upload a file

=cut
sub upload_file {
	my $self = shift;
	my $q = $self->query;

	my $homedir = $self->session->param("homedir");
	my $workdir = $self->_untaint_path($q->param("workdir"));

	my $upload = CGI::Upload->new();
	my $file_name = $upload->file_name('filename');
	my $in = $upload->file_handle('filename');
	
	if (ref $in ne "IO::File") {
		warn "No file handle in upload ? '$file_name'";
		return $self->message("Hmm, strange. Please contact the administrator");
	}

	if ($file_name =~ /\.\./) {
		warn "two dots in upload file ? '$file_name'";
		return $self->message("Hmm, we don't recognize this. Please contact the administrator");
	}
	if ($file_name =~ /^([\w.-]+)$/) {
		$file_name = $1;
		if (open my $out, ">", File::Spec->catfile($homedir, $workdir,$file_name)) {
			my $buff;
			while (read $in, $buff, 500) {
				print $out $buff;
			}
		} else {
			warn "Could not open local file: '$file_name'";
			return $self->message("Could not open local file. Please contact the administrator");
		}
	} else {
		warn "Invalid name for upload file ? '$file_name'";
		return $self->message("Hmm, we don't recognize this. Please contact the administrator");
	}

	$self->list_dir;
}

=head2 create_directory

Create a directory

=cut
sub create_directory {
	my $self = shift;
	my $q = $self->query;

	my $homedir = $self->session->param("homedir");
	my $workdir = $self->_untaint_path($q->param("workdir"));
	my $dir = $q->param("dir");
	$dir = $self->_untaint($dir);
	if (not $dir) {
		warn "invalid directory: '" . $q->param("dir") . "'";
		return $self->message("Invalid directory name ? Contact the administrator");
	}

	mkdir File::Spec->catfile($homedir, $workdir, $dir);

	$self->list_dir;
}

=head2 DEFAULT

To get the default behavior you can write the following code.
The module will use the built in templates to create the pages.

 #!/usr/bin/perl -wT
 use strict;
 
 use CGI::FileManager;
 my $fm = CGI::FileManager->new(
			PARAMS => {
				AUTH => {
					PASSWD_FILE => "/home/user/mypwfile",
				}
			}
		);
 $fm->run;


=over 4

=item new(OPTIONS)

=back

=head2 META-DATA

Theoretically we could manage some meta-data about each file in some database that
can be either outside our virtual file system or can be a special file in each 
directory.

( run in 1.136 second using v1.01-cache-2.11-cpan-b16cb0d3907 )