B.2 Intranet File Manager

B.2.1 Perl-Script

#!/soft/bin/perl5 -w

#---------------------------------------

# IM.cgi IntraManager: Hauptprogramm

# Initialisierung, Auswertung der Anforderung

#

# Autor: Christoph Metten fuer die FH Regensburg

# Datum: 20.8.1997

#

# Quelle: SiteMgr, a web site file manager

# http://www.halcyon.com/sanford/cgi/sitemgr/

#

# Aenderungen: 20.08.97 cm Seitenvorschau-Button entfernt

# Aktionsschalter in Deutsch

# Einlesen des JavaScripts ohne Kommentare

# 28.08.97 cm CGI.pm an einheitlicher Stelle: /soft1/lib

#

#---------------------------------------

use lib '/soft1/lib';

use CGI;

use File::Copy;

use strict;

#my( );

my ($q, $script_url, $top_dir, $target_item, $ScriptUrl,

$current_dir, $target_dir, $errMsg );

$q = new CGI;

#---------------------------------------

# INITIALIZATION

# Find out who and where we are.

# We assume top web directory is parent of script's directory

# We won't browse or write above the top directory.

$script_url = $ENV{'SCRIPT_NAME'};

($top_dir = $script_url) =~ s%/[^/]+/[^/]+$%%; # parent of script directory

#-------------

# set initial defaults

$target_dir = $top_dir;

$errMsg = '';

#-------------

# Many form requests will supply a current directory and target

# item, both full paths.

$target_item = $q->param('item') if $q->param('item');

$current_dir = $q->param('dir') if $q->param('dir');

#---------------------------------------

# PROCESS REQUESTS

# Now we begin to process requests, which can be of two sorts:

# a directory index request or a request for a file operation.

#-------------

# Directory index request

# Check for PATH_INFO. It should come from clicking on a

# directory in the index list, requesting a listing of that

# directory.

if ( $ENV{'PATH_INFO'} ) {

$target_dir = $ENV{'PATH_INFO'};

if ($errMsg = &validate_item ($top_dir, $target_dir)) {

$target_dir = ($current_dir ? $current_dir : $top_dir);

}

&print_web_page ($script_url, $top_dir, $target_dir, $errMsg);

exit;

}

#-------------

# Process requests for file operations

# This is a switch statement over the 'operation' form tag

for ($q->param('operation')) {

#-------------

# Edit request

/^Editieren$/ and do {

# Normally, &print_edit_page will exit the script, but

# not if error messages are returned.

unless ($errMsg = &validate_item ($top_dir, $target_item)) {

$errMsg = &print_edit_page ($target_item);

}

last;

};

#-------------

# Save an edited file

# generated from the edit page

/^Sichern$/ and do {

unless ($errMsg = &validate_item ($top_dir, $target_item)) {

$errMsg = &save_changes( $q->param('text'),

$target_item );

}

# set target dir from url

($target_dir = $target_item) =~ s#/[^/]+$##;

last;

};

#-------------

# Preview an edited file

# generated from the edit page

/^Seitenvorschau$/ and do {

# Normally this will exit, unless there is an error message

$errMsg = &preview_changes ($q->param('text'), $target_item );

last;

};

#-------------

# Delete a file or directory

/^Entfernen$/ and do {

unless ($errMsg = &validate_item ($top_dir, $target_item)) {

$errMsg = &delete_item ($target_item);

}

last;

};

#-------------

# Copy a file or directory

/^Kopieren$/ and do {

# validate the old and new names;

# the first error, if any, should short circuit

$errMsg = &validate_new_url($top_dir, $q->param('newName'))

or $errMsg = &validate_item($top_dir, $target_item)

or $errMsg = &move_or_copy ($target_item,

$q->param('newName'), "cp");

last;

};

#-------------

# Move a file or directory

/^Verschieben$/ and do {

# validate the old and new names;

# the first error, if any, should short circuit

$errMsg = &validate_new_url($top_dir, $q->param('newName'))

or $errMsg = &validate_item($top_dir, $target_item)

or $errMsg = &move_or_copy ($target_item,

$q->param('newName'), "mv");

last;

};

#-------------

# Create a new file in the current directory

/^neue_Datei$/ and do {

$errMsg = &validate_new_url($top_dir, $q->param('newName'))

or $errMsg = &create_file_or_dir('file',

$q->param('newName'))

or $errMsg = &print_edit_page ($q->param('newName'));

last;

};

#-------------

# Create a new directory

/^neues_Verzeichnis$/ and do {

$errMsg = &validate_new_url($top_dir, $q->param('newName'))

or $errMsg = &create_file_or_dir('dir',

$q->param('newName'));

last;

};

#-------------

# Upload a file

/^Upload$/ and do {

$current_dir = $top_dir unless $current_dir;

my ($remoteUploadName) = $q->param('remoteUploadName');

my ($newUploadName) = $q->param('newUploadName');

unless ($remoteUploadName and $newUploadName) {

$errMsg = "<dt><h2>Anforderung nicht erfüllt:</h2>

<dd>Sie müssen eine Datei für den

Upload auswählen <i>und</i> einen

Dateinamen auf dem Server abgeben.\n\n";

last;

}

unless ($errMsg = &validate_new_url($top_dir,

"$current_dir/$newUploadName")) {

my ($tmpFileName) = $q->tmpFileName($remoteUploadName);

$errMsg = &upload_file($newUploadName, $tmpFileName);

}

last;

}

} # end of for( operation )

#---------------------------------------

# All that's left is to print the web page

# Target directory has been initialized to top directory.

# Set it to current dir if it exists and validate it.

if ($current_dir) {

$target_dir = $current_dir;

if ( &validate_item($top_dir, $target_dir) ) {

# returns null message if ok

$target_dir = $top_dir;

}

&print_web_page ($script_url, $top_dir, $target_dir, $errMsg);

#---------------------------------------

# Unterprogramm translate_url2fs

# Translates a url path (without the http://domain.name part)

# to a file system path

# If a scalar (a single url) ) is the only argument,

# then a scalar is returned. If a list of urls are submitted,

# then a list is returned. If error, this subroutine

# (actually &get_prefix) returns a web page and dies.

sub translate_url2fs {

my @urls = @_;

my @fs;

# get fs and url path prefixes

# error checking inside &get_prefix

my ($fs_prefix, $url_prefix) = &get_prefix;

foreach (@urls) {

s/$url_prefix// if $url_prefix; # $url_prefix may be empty

$_ = $fs_prefix . $_;

push @fs, $_;

}

return $fs[0] if @fs == 1;

return @fs;

}

#---------------------------------------

# Unterprogramm get_prefix

# returns ($fs_prefix, $url_prefix)

# the differences between a url path and a fs path

# return web page and die on failure

sub get_prefix {

my($url_path,$fs_path) = ($ENV{'SCRIPT_NAME'},$ENV{'SCRIPT_FILENAME'});

my($fs_prefix) = '';

# try to match one inside the other, if so remove it

while (! ($url_path =~ s/$fs_path$//) ) {

# chop off first directory from front of fs path and save it,

unless ( $fs_path =~ s/(^\/[^\/]+)// ) {

# if we have run out of path, return web page and die

print "Content-type: text/html\n\n

<h1>Interner Programmfehler:

kann Präfix nicht finden.</h1>

Es ist ein interner Fehler (Pfadangabe)

aufgetreten. Es wurden an Ihren

Web-Dokumenten keine Änderungen

durchgeführt.<br>

Bitte notieren Sie folgende Informationen

und benachrichtigen Sie Ihren Administrator.

<ul><li>fs_prefix: $fs_prefix<li>\$1:

$1<li>url_path: $url_path

<li>SCRIPT_NAME: $ENV{'SCRIPT_NAME'}

<li>SCRIPT_FILENAME: $ENV{'SCRIPT_FILENAME'}";

# print "</ul>Environment:<ul>";

# foreach (keys %ENV) {

# print "<li>$_: $ENV{$_}\n";

# }

print "</ul>";

exit;

}

$fs_prefix .= $1;

}

# url path is now a prefix

return ($fs_prefix, $url_path);

}

#---------------------------------------

# Unterprogramm validate_new_url

# performs various checks on a new file or directory name

# we don't check for previous existence of new name,

# to allow mv or copy to overwrite

# supplied as part of an action

# returns error message if not ok

# new_url must be a full url path

sub validate_new_url {

my ($top_url_dir, $new_url) = @_;

# check that a new name is supplied

unless ($new_url) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Sie müssen einen neuen Namen für

die Datei oder das Verzeichnis angeben.\n\n";

}

# sanitize the name to prevent shell escapes

if ($new_url =~ /[^\w-~\/\.]/) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Pfadnamen dürfen nur aus Buchstaben,

Ziffern und folgenden Zeichen bestehen: _ - ~ / \<br>

Es dürfen keine Leerzeichen enthalten sein.

Bitte geben Sie einen neuen Namen an.\n\n";

}

# check that new path is within web site

unless ($new_url =~ /^$top_url_dir/) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Der angegebene Pfadname existiert nicht

innerhalb Ihres WWW-Bereiches.

Bitte geben Sie einen neuen Pfad an.\n\n";

}

# for this demo, disable server side includes by excluding

# *.shtml file. You will probably want to comment out ths section.

if ($new_url =~ /shtml$/) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Aus Sicherheitsgründen werden Server Sides

Includes nicht zugelassen. Dateien mit der Endung

<tt>*.shtml</tt> sind nicht erlaubt.

Bitte wählen Sie einen anderen.\n\n";

}

# end of server side includes exclusion

# all ok, return empty error message

return '';

}

#---------------------------------------

# Unterprogramm validate_item

# perform various checks on an item selected

# from the directory index

# returns error message if not ok

sub validate_item {

my ($top_url_dir, $url_item) = @_; #<F12># top 1st if url_item = ''

# check that a $url_item has been selected

unless ($url_item) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Sie müssen eine Datei oder ein Verzeichnis

in der Liste auswählen.\n\n";

}

# Check that the item is within the web site.

# This shouldn't happen unless someone is pointing their own form here

# which also shouldn't happen - but just to be safe...

unless ($url_item =~ /^$top_url_dir/) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Das von Ihnen gewählte Element

<i>$url_item</i>

exisitert nicht in Ihrem WWW-Bereich.\n\n";

}

# translate to file system paths

my ($fs_item, $top_fs_dir) = &translate_url2fs( $url_item,

$top_url_dir);

# check for existence and read/write permissions

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Das von Ihnen gewählte Element <i>$url_item</i>

exisitert nicht auf dem Web-Server.\n\n"

unless -e $fs_item;

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Die von Ihnen gewählte Datei <i>$url_item</i>

hat kein Leserecht auf diesem Web-Server.\n\n"

unless -r $fs_item;

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Das von Ihnen gewählte Verzeichnis <i>$url_item</i>

hat kein Schreibrecht auf diesem Web-Server.\n\n"

unless -w $fs_item;

# If we get here, all is ok, so return an empty error message.

return '';

}

#---------------------------------------

# Unterprogramm create_file_or_dir

# create a new empty file

# returns error message on error, null string if ok

sub create_file_or_dir {

my ($type, $url) = @_; # $type is 'file' or 'dir',

# $url os full url path

# translate to file system paths

my $fs_item = &translate_url2fs($url);

# check for existence

if (-e $fs_item) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Eine Datei oder ein Verzeichnis <i>$url</i>

existiert bereits.\n\n.";

}

# create the file or dir

if ($type eq 'file') {

unless (open(WR, ">$fs_item")) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Konnte Datei <i>$url</i> nicht erzeugen.

Grund: $!\n\n";

}

print WR '';

close WR;

chmod 0644, "$fs_item";

} elsif ($type eq 'dir') {

unless ( mkdir $fs_item, 0755 ) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Konnte Verzeichnis <i>$url</i> nicht

erzeugen. Grund: $!\n\n";

}

} else {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Interner Fehler: unbekannter Dateityp.\n\n";

}

return '';

}

#---------------------------------------

# Unterprogramm move_or_copy

# move or copy old_item to new_item

# both parameters are fs path

sub move_or_copy {

my ($old_url_item, $new_url_item, $op) = @_;

my ($oped) = $op eq "mv" ? "verschoben" : "kopiert";

# translate to file system paths

my ($old_fs_item, $new_fs_item) = &translate_url2fs( $old_url_item,

$new_url_item );

# from File::Copy

unless (copy ($old_fs_item, $new_fs_item)) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Die Datei <i>$old_url_item</i> wurde nicht

nach <i>$new_url_item</i> $oped. Grund: $!.\n\n";

}

if (-d $new_fs_item) {

chmod 0755, "$new_fs_item";

} else {

chmod 0644, "$new_fs_item";

}

if ($op eq "mv") {

unlink $old_fs_item unless $old_fs_item eq $new_fs_item;

}

return "<dt><h2>Anforderung erfüllt: </h2>

<dd>Die Datei <i>$old_url_item</i>wurde nach

<i>$new_url_item</i> $oped.\n\n";

}

#---------------------------------------

# Unterprogramm delete_item

# delete a file or a directory

sub delete_item {

my ($url_item) = @_;

# translate to file system paths

my $fs_item = &translate_url2fs($url_item);

# now delete the item

if (-d $fs_item) {

if (rmdir $fs_item) {

return "<dt><h2>Anforderung erfüllt: </h2>

<dd>Das Verzeichnis <i>$url_item</i>

wurde erfolgreich gelöscht.\n\n";

} else {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Das Verzeichnis <i>$url_item</i> wurde

nicht gelöscht. Grund: $!\n\n";

}

} else {

if (unlink $fs_item) {

return "<dt><h2>Anforderung erfüllt: </h2>

<dd>Die Datei <i>$url_item</i> wurde

erfolgreich gelöscht.\n\n";

} else {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>>Die Datei <i>$url_item</i> wurde

nicht gelöscht. Grund: $!\n\n";

}

#---------------------------------------

# Unterprogramm upload_file

# copies temp file (a fs path) to new url

# CGI.pm expects to delete the temp file

sub upload_file {

my ($new_url_item, $tmpName) = @_;

my (@stat);

# translate to file system paths

my $new_fs_item = &translate_url2fs($new_url_item);

##### This section is used only in the demo version. #####

##### Comment it out to remove upload size limitations. #####

# filesize is $stat[7];

unless ( @stat = stat($tmpName) ) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Interner Fehler: Konnte $tmpName nicht

finden.\n\n";

}

if ($stat[7] > 1000) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Die Datei für den Upload ist zu groß.

Dateien dürfen nur 1 kB (1024 Bytes)

großsein.\n\n";

}

##### End of file size limitation section #####

# from File::Copy

unless (copy ($tmpName, $new_fs_item)) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Interner Fehler: Konnte <i>$tmpName</i> nicht nach

<i>$new_fs_item</i> kopieren. Grund: $!.\n\n"

}

if (-d $new_fs_item) {

chmod 0755, "$new_fs_item";

} else {

chmod 0644, "$new_fs_item";

}

return "<dt><h2>Anforderung erfüllt: </h2>

<dd>Die Datei <i>$tmpName</i> wurde erfolgreich nach

<i>$new_url_item</i> kopiert.\n\n"

}

#---------------------------------------

# Unterprogramm preview_changes

# Write a temporary file containing $text

# in the same directory as the $file and then redirect

# the browser to it. In this way, relative images and links

# will work in the preview. They wouldn't if we simply wrote

# back the html to the browser, since it would be relative to

# the script's directory. We'll fork a process to sleep and

# then delete the temporary file in a few seconds.

sub preview_changes {

my ($text, $url) = @_;

# make CR/LF substitutions in the text

$text =~ s/\r\n/\n/g;

$text =~ s/\r/\n/g;

# translate to file system paths

my $fs_file = &translate_url2fs($url);

# sanitize the file name for shell escapes

$fs_file =~ s/[^\w-~\/\.\,]//g;

# create names and url for temporary files in the same directory

# include process id in the name for uniqueness

unless( $url =~ s/\.html?$/$$.tmp\.html/i

and $fs_file =~ s/\.html?$/$$.tmp\.html/i ) {

print "Content-type: text/html\n\n

Leider ist eine Seitenvorschau nur bei Dateien

mit der Endung .htm oder .html möglich.

Alle anderen Dateien müssen erst gesichert

werden, bevor Sie im Browser betrachtet werden

können.";

exit;

}

# make the temporary file hidden

if ($url =~ /[^\/]*$/ and $fs_file =~ /[^\/]*$/) {

$url =~ s|([^/]*)$|\.$1|;

$fs_file =~ s|([^/]*)$|\.$1|;

}

# write the temporary file

unless ( open (WR, ">$fs_file") ) {

print "Content-type: text/html\n\n

Konnte temporäre Datei nicht öffnen.";

exit;

}

print WR $text;

close WR;

chmod 0644, "$fs_file";

# redirect the browser

$| = 1; # flush buffer so we don't wait.

print "Location: http://$ENV{'SERVER_NAME'}$url\n\n";

# open a process to delete it; since we do not close

# the process, it will live beyond the cgi script

open (PROC, "| sleep 60; rm -f $fs_file");

exit;

}

#---------------------------------------

# Unterprogramm save_changes

# overwrite file at $url with $text

sub save_changes {

my ($text, $url) = @_;

# translate to file system paths

my $fs_file = &translate_url2fs($url);

# make CR/LF substitutions-we assume it's a text file

$text =~ s/\r\n/\n/g;

$text =~ s/\r/\n/g;

unless ( open(WR, ">$fs_file") ) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Konnte Datei <i>$url</i> nicht schreiben.

Grund: $!";

}

print WR "$text";

close WR;

chmod 0644, "$fs_file";

return "<dt><h2>Anforderung erfüllt: </h2>

<dd>Die Datei <i><a href=\"$url\">$url</a></i> wurde

erfolgreich geändert.\n\n";

}

#---------------------------------------

# Unterprogramm print_edit_page

# returns the html code for the edit page

sub print_edit_page {

my ($url_filename) = @_;

my ($text);

# translate to file system paths

my $fs_filename = &translate_url2fs($url_filename);

# we have already validated target, but we still need

# to check if it's a directory

if (-d "$fs_filename") {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd><i>$url_filename ist ein Verzeichnis.

Bitte wählen Sie eine Datei zum Ändern.\n\n";

}

# read in the target file

unless (open (RD, "$fs_filename")) {

return "<dt><h2>Anforderung nicht erfüllt: </h2>

<dd>Kann die Datei <i>$url_filename</i> nicht lesen.

Grund: $!\n\n";

}

$text = join '', <RD>;

close RD;

print "Content-type: text/html\n\n";

print "<html><head><title>Intranet File Manager</title></head>\n

<body bgcolor=\"#ffffff\">\n

<form method=post>\n

<input type=hidden name=item value=\"$url_filename\">

<hr size=2 noshade>

<h2>Dateiname: $url_filename</h2>

<textarea cols=70 rows=15 name=text>$text</textarea><P>";

#Seitenvorschau funktioniert nicht, also weg damit

#cm, 20.8.97

#<input type=submit name=operation value=\"Seitenvorschau\">

print "<input type=submit name=operation value=\"Sichern\"> </form>\n

<hr noshade>\n

<a href=\"http://INTERN.fh-regensburg.de/~cmetten/\">cm</a>

</body></html>";

exit;

}

#---------------------------------------

# Unterprogramm print_web_page

# returns the html code for the filemanager's page

sub print_web_page {

my ($ScriptUrl, $top_url_dir, $target_url_dir, $error_message) = @_;

#-------------

# HTML header

print "Content-type: text/html\n\n";

#-------------

# page header

print "<html><head>\n";

#-------------

# inserting imgr.js: all stuff for handling IntraManager input

print "<SCRIPT LANGUAGE=\"JavaScript\">\n

<!-\n";

open( JAVADAT, "< imgr.js" );

while( <JAVADAT> )

{

# 20.08.97 cm: Ausgabe ohne Kommentar

if( /\/\// ) {

next ;

} else {

print ;

}

close( JAVADAT );

print "// ->\n

</SCRIPT>\n";

#-------------

# rest of page header

print "<title>Intranet File Manager</title></head>\n

<body bgcolor=\"#ffffff\">\n

<blockquote>\n

<dl>\n

<form method=post action=\"$ScriptUrl\" name=\"mainform\"

onSubmit=\"return checkMainForm()\">\n

<input type=hidden name=dir value=\"$target_url_dir\">\n";

# error messages (if any)

print "$error_message\n" if $error_message;

#-------------

# directory index

# local variables used only in directory index !

my ($parent_url_dir, $target_fs_dir, $parent_fs_dir, $filename,

@stat, $mtime, $size, $img, $comment, $fs_prefix, $url_prefix);

print "<dt>\n<H2>Aktuelles Verzeichnis: $target_url_dir/</H2>\n

<dd>\n\n<table>\n

<tr align=center>\n

<td><b>Auswahl</b></td>\n

<td></td>\n

<td><b>Name</b></td>\n

<td><b>Größe</b></td>\n

<td><b>Datum</b></td>\n

<td align=left><b>Typ</b></td>\n

</tr>\n";

# if target dir is strictly below top

if ( $target_url_dir =~ /^$top_url_dir.+/ ) {

($parent_url_dir = $target_url_dir) =~ s/\/\w+$//;

print "<tr><td colspan=6>\n

<A HREF=\"$ScriptUrl$parent_url_dir\">

Verzeichnisebene höher</A></td></tr>";

}

# translate to file system paths

$target_fs_dir = &translate_url2fs($target_url_dir);

# cycle through the files in the directory

unless ( opendir DIR, $target_fs_dir ) {

print "</table><dt><h2>Fataler interner Fehler:</h2>\n

<dd>Bitte teilen Sie folgenden Fehler Ihrem

Systemadministrator mit:\n

Failed opendir: <ul>

<li>script_url: $ScriptUrl...

<li>top_url_dir: $top_url_dir...

<li>target_url_dir: $target_url_dir...

<li>error_message: $error_message...

<li>target_fs_dir: $target_fs_dir...</ul>

Environment: <ul>";

foreach (keys %ENV) {

print "<li>$_: $ENV{$_}\n";

}

print "</ul></dl></blockquote></body></html>";

exit;

}

# $filename is name without path

while ($filename = readdir DIR) {

next if $filename =~ /^\./; # skip hidden files

@stat = stat $target_fs_dir.'/'.$filename;

$mtime = localtime($stat[9]);

$mtime =~ s/^... //;

$mtime =~ s/:\d\d\s+\d\d\d\d//;

$size = $stat[7];

if (-d _) { # a directory

print "<tr><td align=center>\n

<input type=radio name=item

value=\"$target_url_dir/$filename\"

onClick=selectIndexItem(\"$target_url_dir/$filename\")

>

</td>

<td> <IMG ALIGN=absbottom BORDER=0

SRC=\"internal-gopher-menu\"> </td>

<td> <a href=\"$ScriptUrl$target_url_dir/$filename\">

$filename</a></td>

<td align=right>$size Bytes</td>

<td>$mtime </td>

<td>Verzeichnis</td></tr>\n";

next;

}

# .htm or .html file (not dir)

if ($filename =~ /\.html?$/i) {

$img = "internal-gopher-text";

$comment = "HTML-Datei";

}

# gif or jpg

elsif ($filename =~ /\.gif/i or $filename =~ /\.jpg/i) {

$img = "internal-gopher-image";

$comment = "Bilddatei";

}

# .txt file

elsif ($filename =~ /\.txt/i) {

$img = "internal-gopher-text";

$comment = "Textdatei";

} else {

$img = "internal-gopher-unknown";

$comment = 'unbekannter Dateityp';

}

print "<tr><td align=center>\n

<input type=radio

name=item value=\"$target_url_dir/$filename\"

onClick=selectIndexItem(\"$target_url_dir/$filename\")> </td>

<td> <IMG ALIGN=absbottom BORDER=0 SRC=\"$img\"></td>

<td><a href=\"$target_url_dir/$filename\">$filename</a>

</td>

<td align=right>$size Bytes</td>

<td>$mtime </td>

<td>$comment </td></tr>\n";

} # end of while

closedir DIR;

print "</table>\n";

#-------------

# print_file_operations

print "<dt> <h2>Aktionen</h2>\n";

# input field for new file/dir name

print "<dd><b>Neuer Datei- / Verzeichnisname:</b>

<input type=text name=newName value=\"$target_url_dir/\"

size=50> <p>\n";

# operation buttons

print "<dd><table>\n

<tr>\n<td>

<input type=submit name=operation value=\"Editieren\"

onClick=selectAction(\"Editieren\")>

</td>\n<td>

<font size=-1>ausgewählte Datei ändern

</td>\n <td>

<input type=submit name=operation value=\"Entfernen\"

onClick=selectAction(\"Entfernen\")>

</td>\n<td>

<font size=-1>ausgewählte Datei oder Verzeichnis

löschen

</td>\n</tr>\n<tr>\n<td>

<input type=submit name=operation value=\"Verschieben\"

onClick=selectAction(\"Verschieben\")>

</td>\n<td>

<font size=-1>ausgewählte Datei umbenennen

</td>\n</td>\n<td>

<input type=submit name=operation value=\"Kopieren\"

onClick=selectAction(\"Kopieren\")>

</td>\n<td>

<font size=-1>ausgewählte Datei oder Verzeichnis kopieren

</td>\n</tr>\n<tr>\n<td>

<input type=submit name=operation value=\"neue_Datei\"

onClick=selectAction(\"neue_Datei\")>

</td>\n<td>

<font size=-1>neue Datei erzeugen.

</td>\n<td>

<input type=submit name=operation value=\"neues_Verzeichnis\"

onClick=selectAction(\"neues_Verzeichnis\")>

</td>\n<td>

<font size=-1>Neues Verzeichnis erzeugen

</td>\n</tr>\n

</table>\n";

#-------------

# file upload form

print "</form> <!- still in blockquote and dl ->\n

<dt><h2>Datei-Upload (Netscape)</h2>\n

<dd><form method=post action=\"$ScriptUrl\"

name=\"uploadForm\"

onSubmit=\"return checkUploadForm()\"

enctype=\"multipart/form-data\">\n

<input type=hidden name=dir value=\"$target_url_dir\">\n

<input type=file name=remoteUploadName size=50> <br>\n

volle URL-Pfadangabe: <br>

<input type=text name=newUploadName

value=\"$target_url_dir/\"

onFocus=\"suggestUploadName()\"

size=50>\n

<input type=submit name=operation value=\"Upload\">

</form>\n";

#-------------

# end of page body

print "</dl>\n</blockquote>\n

<hr noshade>\n

<a href=\"http://INTERN.fh-regensburg.de/~cmetten/\">cm</a>

</body></html>\n";

} # end of sub print_web_page

#--E-O-F-----------------------------------

B.2.2 Javascript-Anteil

//---------------------------------------

// IM-script.js IntraManager JavaScripts

// All JavaScripts for handling IntraManager input

//

// Routinen: selectIndexItem(item), selectAction (action),

// checkMainForm (), checkUploadForm (), suggestUploadName ()

//

// Autor: Christoph Metten fuer die FH Regensburg

// Datum: 19.8.1997

//

// Quelle: SiteMgr, a web site file manager

// http://www.halcyon.com/sanford/cgi/sitemgr/

//

// Aenderungen: 20.08.97 cm Aktionsschalter Deutsch

//---------------------------------------

// global variables for file or directory item selected

// and for the action selected (except upload))

var indexItemSelected = "";

var actionSelected = "";

//---------------------------------------

// onClick handler for radio buttons

// item = url path to file or directory

function selectIndexItem(item)

{

indexItemSelected = item;

}

//---------------------------------------

// onClick handler for submit buttons

function selectAction (action)

{

actionSelected = action;

}

//---------------------------------------

// validate form data for various actions on main form

function checkMainForm ()

{

//-------------

// Edit Schalter

if (actionSelected == "Editieren")

{

if (indexItemSelected == "")

{

alert("Sie muessen eine Datei im Index Auswaehlen.");

return (false);

}

return (true);

}

//-------------

// Remove Schalter

if (actionSelected == "Entfernen")

{

if (indexItemSelected == "")

{

alert("Sie muessen eine Datei oder ein Verzeichnis " +

"zum Loeschen auswaehlen.");

return (false);

}

if( confirm("Sind Sie sicher, dass Sie die Datei " +

indexItemSelected + " loeschen wollen? " +

"Geloeschte Dateien koennen nicht " +

" wieder hergestellt werden."))

{

return (true);

}

return (false);

}

//-------------

// Move Schalter

if (actionSelected == "Verschieben")

{

if (indexItemSelected == "")

{

alert("Sie muessen zum Verschieben eine Datei oder " +

"ein Verzeichnis aus dem Index auswaehlen.");

return (false);

}

if (document.mainform.newName.value.length < 1

|| document.mainform.newName.value

== document.mainform.dir.value + "/")

{

alert("Sie muessen einen neuen Namen fuer " +

indexItemSelected + " angeben.");

return (false);

}

return (true);

}

//-------------

// Copy Schalter

if (actionSelected == "Kopieren")

{

if (indexItemSelected == "")

{

alert("Sie muessen eine Datei oder ein Verzeichnis " +

"zum Kopieren auswaehlen.");

return (false);

}

if (document.mainform.newName.value.length < 1

|| document.mainform.newName.value

== document.mainform.dir.value + "/")

{

alert("Sie muessen einen neuen Namen fuer " +

indexItemSelected + " angeben.");

return (false);

}

return (true);

}

//-------------

// Create Directory Schalter

if (actionSelected == "neues_Verzeichnis") {

if (document.mainform.newName.value.length < 1

|| document.mainform.newName.value

== document.mainform.dir.value + "/")

{

alert("Sie muessen einen neuen Namen fuer das " +

"Verzeichnis angeben.");

return (false);

}

return (true);

}

//-------------

// Create File Schalter

if (actionSelected == "neue_Datei") {

if (document.mainform.newName.value.length < 1

|| document.mainform.newName.value == document.mainform.dir.value

+ "/") {

alert("Sie muessen einen neuen Namen fuer die Datei " +

"angeben.");

return (false);

}

return (true);

}

//---------------------------------------

// validate upload data

function checkUploadForm ()

{

var errmsg = "";

if (document.uploadForm.newUploadName.value.length < 1

|| document.uploadForm.newUploadName.value

== document.mainform.dir.value + "/")

{

errmsg = "Sie m|ssen einen Namen f|r dei Datei angeben,\\n" +

"die Sie auf den Web-Server laden wollen.";

}

if (!errmsg)

{

return true;

}

alert(errmsg);

return false;

}

//---------------------------------------

// for file upload, get filename and write it to suggested new name.

function suggestUploadName ()

{

// for UNIX:

var pos = document.uploadForm.remoteUploadName.value.lastIndexOf("/");

//for DOS

var len = document.uploadForm.remoteUploadName.value.length;

if (pos < 0)

{

pos = document.uploadForm.remoteUploadName.value.lastIndexOf("\\\\");

}

if (pos < 0)

{

pos = 0;

}

document.uploadForm.newUploadName.value +=

document.uploadForm.remoteUploadName.value.substring(pos+1,len);

}

//---------------------------------------

// END OF JAVASCRIPT

10/6/1997