package Apache::FileManager;
=head1 NAME
Apache::FileManager - Apache mod_perl File Manager
=head1 SYNOPSIS
# Install in mod_perl enabled apache conf file
SetHandler perl-script
PerlHandler Apache::FileManager
(Then point your browser to http://www.yourwebsite.com/FileManager)
# Or call from your own mod_perl script
use Apache::FileManager;
my $obj = Apache::FileManager->new();
$obj->print();
# Or create your own custom MyFileManager subclass
package MyFileManager;
use strict;
use Apache::FileManager;
our @ISA = ('Apache::FileManager');
sub handler {
my $r = shift;
my $obj = __PACKAGE__->new();
$r->send_http_header('text/html');
print ("
".$r->server->server_hostname." File Manager
");
$obj->print();
print "";
}
# .. overload the methods ..
=head1 DESCRIPTION
The Apache::FileManager module is a simple HTML file manager. It provides
file manipulations such as cut, copy, paste, delete, rename, extract archive,
create directory, create file, edit file, and upload files.
Apache::FileManager also has the ability to rsync the server htdocs tree to
another server. With the click of a button.
=head1 PREREQUISITES
The following (non-core) perl modules must be installed before installing
Apache::FileManager.
Apache::Request => 1.00
Apache::File => 1.01
File::NCopy => 0.32
File::Remove => 0.20
Archive::Any => 0.03
CGI::Cookie => 1.20
=head1 SPECIAL NOTES
Make sure the web server has read, write, and execute access access to the
directory you want to manage files in. Typically you are going to want to
run the following commands before you begin.
chown -R nobody /web/xyz/htdocs
chmod -R 755 /web/xyz/htdocs
The extract functionality only works with *.tar.gz and *.zip files.
=head1 RSYNC FEATURE
To use the rync functionality you must have ssh, rsync, and the File::Rsync
perl module installed on the development server. You also must have an sshd
running on the production server.
Make sure you always fully qualify your server names so you don't have
different values in your known hosts file.
For Example:
ssh my-machine - wrong
ssh my-machine.subnet.com - right
Note: If the ip address of the production_server changes you will need to
create a new known_hosts file.
To get the rsync feature to work do the following:
#1 log onto the production server
#2 become root
#3 give web server user (typically nobody) a home area
I made mine /usr/local/apache/nobody
- production_server> mkdir /usr/local/apache/nobody
- edit passwd file and set new home area for nobody
- production_server> mkdir /usr/local/apache/nobody/.ssh
#4 log onto the development server
#5 become root
#6 give web server user (typically nobody) a home area
- dev_server> mkdir /usr/local/apache/nobody
- dev_server> chown -R nobody.nobody /usr/local/apache/nobody
- edit passwd file and set new home area for nobody
- dev_server> su - nobody
- dev_server> ssh-keygen -t dsa (don't use passphrase)
- dev_server> ssh production_server
(will fail but will make known_hosts file)
- log out from user nobody back to root user
- dev_server> cd /usr/local/apache/nobody/.ssh
- dev_server> scp id_dsa.pub production_server:/usr/local/apache/nobody/.ssh/authorized_keys
- dev_server> chown -R nobody.nobody /usr/local/apache/nobody
- dev_server> chmod -R 700 /usr/local/apache/nobody
#7 log back into the production server
#8 become root
#9 Do the following commands:
- production_server> chown -R nobody.nobody /usr/local/apache/nobody
- production_server> chmod -R 700 /usr/local/apache/nobody
You also need to specify the production server in the development server's
web conf file. So your conf file should look like this:
SetHandler perl-script
PerlHandler Apache::FileManager
PerlSetVar RSYNC_TO production_server:/web/xyz
If your ssh path is not /usr/bin/ssh or /usr/local/bin/ssh, you also need to
specify the path in the conf file or in the contructor with the directive
SSH_PATH.
You can also specify RSYNC_TO in the constructor:
my $obj = Apache::FileManager->new({
RSYNC_TO => "production_server:/web/xyz"
});
Also make sure /web/xyz and all files in the tree are readable, writeable, and
executable by nobody on both the production server AND the development server.
=head1 USING DIFFERENT DOCUMENT ROOT
You can specify a different document root as long as the new document root
falls inside of the orginal document root. For example if the document root
of a web server is /web/project/htdocs, you could assign the document root to
also be /web/project/htdocs/newroot. The directory `newroot` must exist.
# Specify different document root in apache conf file
SetHandler perl-script
PerlHandler Apache::FileManager
PerlSetVar DOCUMENT_ROOT /web/project/htdocs/newroot
# Or specify different document root in your own mod_perl script
use Apache::FileManager;
my $obj = Apache::FileManager->new({
DOCUMENT_ROOT => '/web/project/htdocs/newroot'
});
$obj->print();
=head1 SUBCLASSING Apache::FileManager
# Create a new file with the following code:
package MyProject::MyFileManager;
use strict;
use Apache::FileManager;
our @ISA = ('Apache::FileManager');
#Add your own methods here
1;
The best way to subclass the filemanager would be to copy the methods you want
to overload from the Apache::FileManager file to your new subclass. Then change
the methods to your liking.
=head1 BUGS
There is a bug in File::NCopy that occurs when trying to paste an empty
directory. The directory is copied but reports back as 0 directories pasted.
The author is in the process of fixing the problem.
=head1 AUTHOR
Apache::FileManager was written by Philip Collins
Epmc@cpan.orgE.
=cut
use strict;
#use warnings;
use IO::File;
use Apache::Request;
use Apache::Util qw(escape_html);
use Apache::File;
use File::NCopy qw(copy);
use File::Copy qw(move);
use File::Remove qw(remove);
use File::stat;
use Archive::Any;
use POSIX qw(strftime);
use CGI::Cookie;
use Apache::Constants ':common';
#use Data::Dumper;
require 5.005_62;
our $VERSION = '0.19';
sub r { return Apache::Request->instance( Apache->request ); }
# ---------- Object Constructor -----------------------------------------
sub new {
my $package = shift;
my $attribs = shift || {};
my $o = bless $attribs, $package;
$o->intialize();
$o->execute_cmds();
return $o;
}
# ---- If this was called directly via a perl content handler by apache -------
sub handler {
return DECLINED if defined r->param('nossi');
my $package = __PACKAGE__;
my $obj = $package->new();
r->send_http_header('text/html');
r->print("".r->server->server_hostname." File Manager $VERSION");
$obj->print();
r->print("");
return OK;
}
# ---- Call the view ----------------------------------------------
sub print {
my $o = shift;
my $view = "view_".$$o{'view'};
$o->$view();
}
# ------------ Intialize object -----------------------------------------
sub intialize {
my $o = shift;
$$o{MESSAGE} = "";
$$o{JS} = "";
$o->{EDIT_COLS} ||= 75;
$o->{EDIT_ROWS} ||= 22;
# Is this filemanager rsync capable?
$$o{'RSYNC_TO'} ||= r->dir_config('RSYNC_TO') || undef;
#set some defaults (for warnings sake)
r->param('FILEMANAGER_cmd' => "")
unless defined r->param('FILEMANAGER_cmd');
r->param('FILEMANAGER_arg' => "")
unless defined r->param('FILEMANAGER_arg');
r->param('FILEMANAGER_curr_dir' => "")
unless defined r->param('FILEMANAGER_curr_dir');
r->param('FILEMANAGER_sel_files' => [])
unless defined r->param('FILEMANAGER_sel_files');
#document root
my $dr = r->document_root;
$$o{DR} ||= r->dir_config('DOCUMENT_ROOT') || r->document_root;
#does user defined document root lie inside real doc root?
if ($$o{DR} !~ /^$dr/) {
$$o{DR} = r->document_root;
r->log_error("Warning: Document root changed to $dr. Custom document root must lie inside of real document root.");
}
#verify current working directory
$_ = r->param('FILEMANAGER_curr_dir');
s/\.\.//g; s/^\///; s/\/$//;
my $curr_dir = $_;
#set current directory
if (! chdir $$o{DR}."/$curr_dir") {
chdir $$o{DR};
$curr_dir = "";
}
r->param('FILEMANAGER_curr_dir' => $curr_dir);
#set default view method
$$o{'view'} = "filemanager";
return undef;
}
###############################################################################
# ----- Views --------------------------------------------------------------- #
###############################################################################
#after upload files - view
sub view_post_upload {
my $o = shift;
r->print("");
return undef;
}
#after rsync transacation - view
sub view_post_rsync {
my $o = shift;
r->print("
$$o{MESSAGE}
");
return undef;
}
sub view_filemanager {
my $o = shift;
my $message = "".$$o{MESSAGE}."";
my ($location, $up_a_href) = $o->html_location_toolbar();
$up_a_href = "" if !defined($up_a_href);
r->print("
".$o->html_javascript."
".$o->html_style_sheet()."
");
return undef;
}
sub view_pre_editfile {
my $o = shift;
my $editfile = r->param('FILEMANAGER_editfile');
my $base = "http://".r->server->server_hostname."/$editfile";
$editfile =~ /([^\/]+)$/;
my $filename = $1;
my $fh;
if (-T $filename && -w $filename) {
$fh = IO::File->new("< ".$filename);
}
my $message = "".$$o{MESSAGE}." " if $$o{MESSAGE};
if (! $fh) {
r->print("
$message
could not open file: $base in text writing mode
");
}
else {
my $data;
{ local $/=undef; $data = scalar(<$fh>); }
r->print("
".$o->html_style_sheet()."
");
}
return undef;
}
###############################################################################
# ---- HTML Component Output ------------------------------------------------ #
###############################################################################
sub html_javascript {
my $o = shift;
my $cookie_name = uc(r->server->server_hostname);
$cookie_name =~ s/[^A-Z]//g;
$cookie_name .= "_FM";
#start return literal
return "
"; #end return literal
}
### end sub html_javascript
sub html_style_sheet {
my $o = shift;
return ("
")
}
sub html_hidden_fields {
my $o = shift;
return "
";
}
sub html_location_toolbar {
my $o = shift;
my @loc = split /\//, r->param('FILEMANAGER_curr_dir');
#already in base directory?
return "location: / " if ($#loc == -1);
#for all elements in the loc except the last one
my @ac;
my $up_a_href = ".. ";
for (my $i = 0; $i < $#loc; $i++) {
push @ac, $loc[$i];
my $url = join("/", @ac);
$loc[$i] = "".$loc[$i]."";
if ($i == ($#loc - 1)) {
$up_a_href = ".. ";
}
}
$loc[$#loc] = "".$loc[$#loc]."";
my $location = "location: / ".join(" / ", @loc);
return ($location, $up_a_href);
}
sub html_cmd_toolbar {
my $o = shift;
my @cmds = (
#Refresh
"refresh",
#Edit
"edit",
#Cut
"cut",
#Copy
"copy",
#Paste
"paste",
#Delete
"delete",
#Rename
"rename",
#Extract
"extract",
#New File
"uri."?FILEMANAGER_cmd=editfile&FILEMANAGER_curr_dir='+escape(cd)+'&FILEMANAGER_editfile='+escape(rv), 'FileManagerEditFile', 'scrollbars,resizable');
w.focus();
} else if (rv == '') {
window.alert('can not create blank file names');
}
return false;
\">new file",
#New Directory
"new directory",
#Upload
"upload"
);
#Rsync
my $rsync = "";
if ($$o{'RSYNC_TO'}) {
push @cmds, "
";
}
sub html_file_list {
my $o = shift;
my $up_a_href = shift || "";
my $bgcolor = "efefef";
#get the list in this directory
my $curr_dir = "";
$curr_dir = r->param('FILEMANAGER_curr_dir')."/"
if (r->param('FILEMANAGER_curr_dir') ne "");
#if there is a value for the ".." directory, then add a row for that link
#at the *top* of the list
my $acum = "";
if ($up_a_href ne "") {
$acum = "
$up_a_href
--
--
";
$bgcolor = "ffffff";
}
my $ct_rows = 0;
foreach my $file (sort <*>) {
my ($link,$last_modified,$size,$type);
$ct_rows++;
#if directory?
if (-d $file) {
$last_modified = "--";
$size = "
";
#alternate bgcolor so it is easier to read
$bgcolor = ( ($bgcolor eq "ffffff") ? "efefef" : "ffffff" );
}
#print a message if there were no files in this directory
if ($ct_rows == 0) {
$acum .= "