"Fossies" - the Fresh Open Source Software archive

Member "SiteMgrYAP/cgi-bin/smgryap.cgi" of archive SiteMgrYAP-0.2.0.tar.gz:

#!/usr/bin/perl

# SiteMgr -- A web site file manager
#            Copyright 1996-7 Sanford Morton. See
#                 http://www.halcyon.com/sanford/cgi/copying.html
#            for copying permissions. See
#                 http://www.halcyon.com/sanford/cgi/sitemgr/
#            for instructions and discussion.

# SiteMgr 0.1.2
#           Copyright 1998-2000 Jose Manuel Macias. macias@cica.es
#
#            Some patches to original version, including:
#                - password and user address authentication
#                - support for multiple users/directories
#

use CGI;
use File::Copy;
use strict;

no strict 'vars';

require "/home/httpd/secure/sitemgr.conf"; 

my ($q, $script_url, $top_dir, $top_fs_dir, $target_item, $user, $crpass, $current_dir, $target_dir, $prev_fs_dir, $target_fs_dir, $errMsg );

#, $DocumentRoot, $SiteMgrURL, $AuthSiteMgrURL, $UploadURL, $HostName); 


# use cgidebug;

$q = new CGI;

### INITIALIZATION --
### Find out who and where we are.
### We won't browse or write above the top directory.
#++ We use $top_dir=UserDir (from auth. script) and
#++        $top_fs_dir=DocumentRoot + UserDir

$script_url = $ENV{'SCRIPT_NAME'};

$top_dir = $q->param('top_dir') if( $q->param('top_dir') );      # from authsmgr.cgi

$top_fs_dir = $DocumentRoot . $top_dir if( $q->param('top_dir') );

$user =  $q->param('user') if $q->param('user');
$crpass =  $q->param('crpass') if $q->param('crpass');

# some servers do not report this

$ENV{'SCRIPT_FILENAME'} = $0 unless $ENV{'SCRIPT_FILENAME'};

### set initial defaults
#++ added default for $target_fs_dir

$target_dir =  $top_dir;
$target_fs_dir = $top_fs_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');

my $operation = "";
$operation = $q->param('operation') if ($q->param('operation'));

### SOME SECURITY.
### If the referring url is not this script, then we refuse to
### process requests; display the default top level page instead.
#++ Referring url can be auth. script too
#++ I included inside this 'if' the directory index request.


if( $ENV{'HTTP_REFERER'} eq ""){          # HTTP_REFERER missing
  
  $errMsg = "<dt><h2><font color=#FF0000>Serious error:</font></h2>
  <dd>SiteMgr will not accept queries from forms differents than 
  the autentication form. You must use it for loging into the system.";
  &print_web_page ($user,$crpass,$DocumentRoot ,$script_url, $prev_fs_dir, $top_fs_dir, $target_fs_dir, $errMsg,$operation);
  exit;
  }else{                                    # HTTP_REFERER ok, but we need check if it is a valid one ...
  
  if( $operation eq "NO_OP" ){                  # No operation but a directory listing ...
    
# here we look for a valid HTTP_REFERER
    
    if ( ($ENV{'HTTP_REFERER'} ne $SiteMgrURL) && ($ENV{'HTTP_REFERER'} ne $AuthSiteMgrURL) && ($ENV{'HTTP_REFERER'} ne $UploadURL)){
      $errMsg = "<dt><h2><font color=#FF0000>Serious error:</font></h2>
      <dd>SiteMgr will not accept requests from forms different 
      from itself or the authentication form.
      You must use this page or the authentication form for accesing 
      your account.";
    }
    
#	if no change made ...
    
    $target_fs_dir = $DocumentRoot . $current_dir if( $current_dir );
    
# if subdir button pressed
    
    $target_dir .= "/" . $q->param('subdir') if($q->param('subdir'));
    $target_fs_dir .= "/" . $q->param('subdir') if $q->param('subdir');
    
# if 'previous dir' button dir pressed
    
    $target_fs_dir = $q->param('parent_dir') if $q->param('prevdir');
    
# previous dir values
    
    $prev_fs_dir = $top_fs_dir;
    $prev_fs_dir = $target_fs_dir if $q->param('subdir');
    
    &print_web_page ($user,$crpass,$DocumentRoot ,$script_url, $prev_fs_dir, $top_fs_dir, $target_fs_dir, $errMsg,$operation);
    exit;
    }else{                                   # An operation and after, directory listing ...
    for ($q->param('operation')) {
      
###
###  Edit request:
###
      /^EDIT$/ and do {
        
# Normally, &print_edit_page will exit the script, but
# not if error messages are returned.
        
#	$target_fs_dir = $DocumentRoot . $current_dir if( $current_dir );
        
        unless ($errMsg = &validate_item ($DocumentRoot, $top_fs_dir, $target_item)) {
          $errMsg = &print_edit_page ($user,$crpass,$DocumentRoot,$current_dir,$target_item);
        }
        last;
      };
      
      
###
### Save an edited file:
### generated from the edit page,
      /^Save changes$/ and do {
        
        unless ($errMsg = &validate_item ($DocumentRoot, $top_fs_dir, $target_item)) {
          $errMsg = &save_changes ($q->param('text'), $DocumentRoot , $target_item );
        }
        
# set target dir from url
        
        ($target_dir = $target_item) =~ s#/[^/]+$##;
#$target_dir =  $current_dir if( $current_dir );
        
        last;
      };
      
###
### Preview an edited file
### generated from the edit page
      /^Preview changes$/ and do {
        
# Normally this will exit, unless there is an error message
        $errMsg = &preview_changes ($q->param('text'), $DocumentRoot , $target_item );
        last;
      };
      
      
###
### Delete a file or directory
###
      /^DELETE$/ and do {
        
        unless ($errMsg = &validate_item ($DocumentRoot, $top_fs_dir, $target_item)) {
          $errMsg = &delete_item (  $DocumentRoot, $target_item);
        }
        last;
      };
      
      
###
### Copy
###
      /^COPY$/ and do {
        
# validate the old and new names;
# the first error, if any, should short circuit
        $errMsg = &validate_new_url($top_fs_dir,  $DocumentRoot . $q->param('newName'))
        or $errMsg = &validate_item( $DocumentRoot, $top_fs_dir, $target_item)
        or $errMsg = &move_or_copy ( $DocumentRoot, $target_item, $q->param('newName'), "cp");
        
        last;
      };
      
###
### Move
###
      /^MOVE$/ and do {
        
# validate the old and new names;
# the first error, if any, should short circuit
        $errMsg = &validate_new_url($top_fs_dir, $DocumentRoot . $q->param('newName'))
        or $errMsg = &validate_item($DocumentRoot, $top_fs_dir, $target_item)
        or $errMsg = &move_or_copy ( $DocumentRoot , $target_item, $q->param('newName'), "mv");
        last;
      };
      
      
###
### Create a new file in the current directory
###
      
      /^CREATE$/ and do {
        
        $errMsg = &validate_new_url($top_fs_dir, $DocumentRoot . $q->param('newName'))
        or $errMsg = &create_file_or_dir('file', $DocumentRoot , $q->param('newName'))
        or $errMsg = &print_edit_page ($user,$crpass,$DocumentRoot,$target_fs_dir,$q->param('newName'));
        last;
      };
      
      
###
### Create a new directory
###
      
      /^MKDIR$/ and do {
        
        $errMsg = &validate_new_url($top_fs_dir, $DocumentRoot . $q->param('newName'))
        or $errMsg = &create_file_or_dir('dir', $DocumentRoot , $q->param('newName'));
        last;
      };
      
      
      
###
### Upload a file
###
#++ TODO: multiple upload
      
      /^Upload file$/ and do {
        
        my $upload_dir = $top_dir;
        $upload_dir = $current_dir if $current_dir;
        
        my ($remoteUploadName) = $q->param('remoteUploadName');
        my ($newUploadName) =  $q->param('newUploadName');
        
        unless ($remoteUploadName and $newUploadName) {
          $errMsg = "<dt><font color=#FF0000><h2>Previous action failed:</h2></font><dd>You must select a file for uploading <i>and</i> give a new name for the file uploaded.";
          last;
        }

        unless ($errMsg = &validate_new_url($top_fs_dir, $DocumentRoot . "$newUploadName")) {
          
          my ($tmpFileName) = $q->tmpFileName($remoteUploadName);
          $errMsg = &upload_file($DocumentRoot,$newUploadName, $tmpFileName);
        }
        last;
      };
      
    }            ### end of switch on '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.
    
    $target_fs_dir = $DocumentRoot . $current_dir if( $current_dir );
    $prev_fs_dir = $top_fs_dir;
    
    
    if ($current_dir) {
      $target_fs_dir = $DocumentRoot . $current_dir if( $current_dir );
      $prev_fs_dir = $target_fs_dir;
    }
    
    &print_web_page ( $user,$crpass, $DocumentRoot ,$script_url, $prev_fs_dir, $top_fs_dir, $target_fs_dir, $errMsg,$operation);
    
    
  };  ### end else
  
} ### end if



###
### PROCESS REQUESTS
#
#++ Directory index requests are processed above, here we process
#++ file operations ...


###
### Process requests for file operations.
### This is a switch statement over the 'operation' form tag
###


###############################################

###
### End main body of script
###
### Subroutines follow:

################################################

sub 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.
  
  my @urls = @_;
  my @fs;
  
# get fs and url path prefixes
# error checking inside &get_prefix
  
  my ($fs_prefix, $url_prefix) = &get_prefix;
  
  foreach (@urls) {
    print "modificando: $_\n\n";
    s/$url_prefix// if $url_prefix;        # $url_prefix may be empty
    $_ = $fs_prefix . $_;
#if prefix exists ...
    push @fs, $_;
    print "modificada: $_\n\n";
  }
  
  return $fs[0] if @fs ==1;
  return @fs;
  
}

sub get_prefix {
# returns ($fs_prefix, $url_prefix)
# the differences between a url path and a fs path
# return web page and die on failure
  
  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>Internal error: prefix not found.</h1>
      There is an error (prefixes to a path).
      No change was made for this page. Please, report this error and
      the following information to the webmaster. Thanks.
      <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'}</ul>Environment variables:<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);
}

#################################################
sub 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
  
  my ($top_url_dir, $new_url) = @_;

  my $absolute_top_url_dir = $top_url_dir . "\/";
  
# check that a new name is supplied
  unless ($new_url) {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font>\n<dd>name for file or directory not given.";
  }
  
# sanitize the name to prevent shell escapes
  if ($new_url =~ /[^\w-~\/\.]/) {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font>\n<dd>The path and valid names can be\n letters, numbers and the following characters:\n  _ - ~ / \. and without blank spaces.\n Please, supply a new name.";
  }
  
# check that new path is within web site
  unless ($new_url =~ /^$absolute_top_url_dir/) {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font><dd>Given path to file is not permitted for you. Please, supply a new name.";
  }
  
# disallow double-dots (/../) in path
  if ($new_url =~ m@/\.\./@) {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd>Path must not contain two  dots (..) for referring to a directory above. Please, supply a path with correct names.";
  }
  
  
# all ok, return empty error message
  return '';
}

###################################################

sub validate_item {
# perform various checks on an item selected from the directory index
# returns error message if not ok
  
  my ($doc_root, $top_url_dir, $url_item) = @_;  # top first in case url_item is empty
  
# translate to file system paths
  
  my $fs_item = $doc_root . $url_item;
  my $top_fs_dir = $top_url_dir;
  my $absolute_top_fs_dir = $top_url_dir ; 
  
# check that a $url_item has been selected
  unless ($url_item) {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font><dd>You must select a file or directory from the list.";
  }
  
# 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 ($fs_item =~ /^$absolute_top_fs_dir/) {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font><dd>Selected item from directory, $url_item, is not valid.";
  }
  
# disallow double-dots (/../) in path
  if ($url_item =~ m@/\.\./@) {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd>Path must not contain two  dots (..) for referring to a directory above. Please, supply a path with correct names.";
  }
  
# check for existence and read/write permissions
  return"<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd>Selected item from directory, $url_item, doesn't exist."  unless -e $fs_item;
  
  return"<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd>Selected item from directory, $url_item, can't be read by <i>SiteMgr</i>." unless -r $fs_item;
  
  return"<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd>Selected item from directory, $url_item, doesn't have write permissions for <i>SiteMgr</i>." unless -w $fs_item;
  
# If we get here, all is ok, so return an empty error message.
  return '';
}


#####################################################

sub create_file_or_dir {
# create a new empty file
# returns error message on error, null string if ok
# $type is 'file' or 'dir'
# $url os full url path
  
  my ($type, $doc_root, $url) = @_;
  
# translate to file system paths
  my $fs_item= $doc_root . $url;
  
# check for existence
  if (-e $fs_item) {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd>A file or directory with supplied name, $url, already exists.";
  }
  
# create the file or dir
  if ($type eq 'file') {
    unless (open(WR, ">$fs_item")) {
      return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd> Unable to create the file: $url. Reason: $!";
    }
    print WR '';
    close WR;
    chmod 0644, "$fs_item";
    } elsif ($type eq 'dir') {
    unless ( mkdir $fs_item, 0755 ) {
      return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd>Unable to create the directory: $url. Reason: $!";
    }
    } else {
    return "<dt><font color=#FF0000><h2>Previous action failed:</h2></font> <dd>Internal error: unknown file type.";
  }
  
  return "<dt><font color=#0000FF><h2>Previous action: directory created</h2></font> <dd>Directory <code>$url</code> was successfully created."
  if $type eq 'dir';
  return '';
}

###############################################

sub move_or_copy {
# mv or cp old_item to new_item; both are url paths.
# You could enhance and simplify by simply calling Unix 'mv' or 'cp'
# but with significant security risk. At least verify item types first.
  
  my ($doc_root, $old_url_item, $new_url_item, $op) = @_;
  my ($oped) = $op eq "mv" ? "moved" : "copied";
  
# translate to file system paths
  my ($old_fs_item, $new_fs_item) = ($doc_root . $old_url_item, $doc_root . $new_url_item);
  
# if old item is a file
  if (-f $old_fs_item) {
    
    copy ($old_fs_item, $new_fs_item) or
    return "<dt><h2>Previous action failed: file not $oped</h2> <dd>The file <code>$old_url_item</code> was not $oped to <code>$new_url_item</code>. Reason: $!.";
    chmod 0644, "$new_fs_item";
    if ($op eq "mv") {
      unlink $old_fs_item unless $old_fs_item eq $new_fs_item;
    }
    return "<dt><font color=#0000FF><h2>Previous action: file $oped</h2></font> <dd>The file <code>$old_url_item</code> was successfully $oped to  <code>$new_url_item</code>.";
  }
  
# if old item is a directory
  elsif (-d $old_fs_item) {
    
# read files in directory
    opendir DIR, $old_fs_item or
    return "<dt><h2>Previous action failed: directory not $oped</h2> <dd>Directory <code>$old_url_item</code> could not be read by SiteMgr. Reason: $!.";
#-- no hidden files, nor the current and parent directory
    my @files = grep !/^\./, readdir DIR;
#my @files = readdir DIR;                hay que descartar sólo . y .. (no .filename)
    closedir DIR;
    
    mkdir $new_fs_item, 0755 or
    return "<dt><h2>Previous action failed: directory not $oped</h2> <dd>Directory <code>$new_url_item</code> could not be created. Reason: $!.";
    
# loop over files in the directory
    my ($errlist) = '';
    
    foreach (@files) {
      
      if (-f "$old_fs_item/$_") { # a regular file
        if (copy ("$old_fs_item/$_", "$new_fs_item/$_")) {
          chmod (0644, "$new_fs_item/$_")
          } else {
          $errlist .= "<LI><CODE>$old_url_item/$_</CODE> -- $!\n";
        }
        
        if ($op eq "mv") {
          unlink "$old_fs_item/$_" unless "$old_fs_item/$_" eq "$new_fs_item/$_";
        }
        
        } elsif (-d "$old_fs_item/$_") { # a subdirectory
        $errlist .= "<LI><CODE>$old_url_item/$_</CODE> -- Unable to copy or move recursively subdirectories.\n";
        
        } elsif (-l "$old_fs_item/$_") { # a symlink
        $errlist .= "<LI><CODE>$old_url_item/$_</CODE> -- Unable to copy or move simbolic links.\n";
        
        } else { # unknown type
        $errlist .= "<LI><CODE>$old_url_item/$_</CODE> -- Imposible copiar o mover tipos de fichero desconocidos\n";
      }
    }
    
    if ($errlist) {     # collect list of file errors, if any
      $errlist = "Though, some of the files could not be $oped successfully: <UL>\n$errlist </UL>\nPerhaps, some of them can be $oped individually.";
      $errlist .= "                  This files and the old directory could not be deleted."
      if $op eq 'mv';
      } elsif ($op eq 'mv') { # if no file errors, rmdir if 'mv'
      rmdir $old_fs_item or
      $errlist = "SiteMgr could not delete the old directory <code>$old_url_item</code>, though files into it could be moved. Reason: $!";
    }
    return "<dt><h2>Previous action: directory $oped</h2> <dd>Directory <code>$old_url_item</code> was $oped to <code>$new_url_item</code>. $errlist";
  }
  
# do not copy symlinks
  elsif (-l $old_fs_item) {
    return "<dt><h2>Previous action failed: file not $oped</h2> <dd>File <code>$old_url_item</code> is a simbolic link. SiteMgr dosn't work with simbolic links by security reasons.";
  }
  
# unknown type
  else {
    return "<dt><h2>Previous action failed: item not $oped</h2> <dd>Item <code>$old_url_item ($old_fs_item)</code> is not a regular file or directory. SiteMgr doesn't work with unknown file types by security reasons.";
  }
}

#########################################################

sub delete_item {
# delete a file or directory
  my ($DocumentRoot ,$url_item) = @_;
  
# translate to file system paths
  my  $fs_item = $DocumentRoot . $url_item;
  
# now delete the item
  if (-d $fs_item) {
    if (rmdir $fs_item) {
      return "<dt><font color=#0000FF><h2>Previous action: Directory deleted</h2></font><dd>Directory <code>$url_item</code> was successfully deleted.";
      } else {
      return "<dt><h2>Previous action failed:</h2> <dd>Directory <code>$url_item</code> was not deleted. Reason: $!";
    }
    } else {
    if (unlink $fs_item) {
      return "<dt><font color=#0000FF><h2>Previous action: File deleted</h2></font> <dd>File <code>$url_item</code> was successfully deleted.";
      } else {
      return "<dt><h2>Previous action failed:</h2><dd>File <code>$url_item</code > was not deleted. Reason: $!";
    }
  }
}




###############################################################

sub upload_file {
# copies temp file (a fs path) to new url
# CGI.pm expects to delete the temp file
  my ($doc_root, $new_url_item, $tmpName) = @_;
  my (@stat);
  
# translate to file system paths
  
  my  $new_fs_item = $doc_root . $new_url_item;
  
#  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];
#++ No limitations for uploading ... uncoment this section and change to the desired limit.
#++
#++  unless ( @stat = stat($tmpName) ) {
#++    return "<dt><h2>Previous action failed:</h2>
#++            <dd>Internal error: when trying to find $tmpName.\n\n";
#++  }
#++  if ($stat[7] > 1000) {
#++    return "<dt><h2>Previous action failed:</h2>
#++            <dd>The file you requested to upload is too large. In this demo
#++            uploaded files must be smaller than 1 kb (1,000 bytes).\n\n";
#++  }
##### End of file size limitation section #####
  
# from File::Copy
  unless (copy ($tmpName, $new_fs_item)) {
    return "<dt><font color=#0000FF><h2>Previous action failed: file not uploaded</h2></font> <dd>Internal error: failed when copying temporal file. Reason: $!."
  }
  
  if (-d $new_fs_item) {
    chmod 0755, "$new_fs_item";
    } else {
    chmod 0644, "$new_fs_item";
  }
  
  return "<dt><font color=#0000FF><h2>Previous action: file uploaded</h2></font> <dd>The file was successfully uploaded as <code>$new_url_item</code>."
}




###########################################################

sub 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.
  
  my ($text,$DocumentRoot,$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);
  
  my $fs_file = $DocumentRoot . $url;    #dummy asignation 'cause we don't use translate_url2fs
  
  $fs_file =~ s/[^\w-~\/\.\,]//g;    # sanitize the file name for shell escapes
  
# 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\nSorry, only the files ended with .htm or .html can be previewed. Other files must be saved before previewed with your browser.";
    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\nFailed when opening temporal file.";
    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 2; rm -f $fs_file");
  exit;
}



###################################################

sub save_changes {
# overwrite file at $url with $text
  my ($text, $DocumentRoot ,$url) = @_;
  
# translate to file system paths
#my $fs_file = &translate_url2fs($url);
  my $fs_file = $DocumentRoot . $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>Previous action failed</h2> <dd>Unable to write $url. Reason: $!";
  }
  print WR "$text";
  close WR;
  chmod 0644, "$fs_file";
  
  return "<dt><font color=#0000FF><h2>Previous action: file edited</h2></font> <dd>The file <a href=\\\"http:\/\/$ENV{SERVER_NAME}/$url\\\" target=_blank>$url</a> was successfully edited.";
}



#####################################################

sub print_edit_page {
  my ($user,$crpass,$DocumentRoot,$cur_url_dir,$url_filename) = @_;
  my ($text);
  
  
# translate to file system paths
  my $fs_filename = $DocumentRoot . $url_filename;
  
  ($cur_url_dir = $url_filename) =~ s#/[^/]+$##;
  
# we have already validated target, but we still need
# to check if it's a directory
  if (-d "$fs_filename") {
    return "<dt><h2>Previous action failed</h2> <dd>$url_filename is a directory. Please, select a file to edit.";
  }
  
# read in the target file
  unless (open (RD, "$fs_filename")) {
    return "<dt><h2>Previous action failed</h2> <dd>Unable to read the file $url_filename. Reason: $!";
  }
#    $text = join '', <RD>;
  
#		while(<RD>){
#			$_ =~ s/\n/ /g;
#			$_ =~ s/\"/\\\"/g;
#			chop $_;
#  		$text .= "\"" . $_ . "\\n\"" . "+";
#	  };
  
#		chop $text;  # the latest '\n'
  
#   close RD;

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

  <head>
  <script language="JavaScript">
  
  EditFile=open("","DisplayWindow","location=no,status=no,menubar=no,directories=no");
  EditFile.document.open();
  EditFile.document.write("<html>\\n<head>\\n<title>SiteMgr Editor</title>\\n");
  EditFile.document.write("</head>\\n<body bgcolor='#ffffff' link='#004400' vlink='#006600'>\\n");
    
    EditFile.document.write("<form name=editform method=post action='$script_url' target=FileListing>\\n");
    
    EditFile.document.write("<input type=hidden name=user value='$user'>\\n");
    EditFile.document.write("<input type=hidden name=crpass value='$crpass'>\\n");
    EditFile.document.write("<input type=hidden name=item value='$url_filename'>\\n");
    EditFile.document.write("<input type=hidden name=top_dir value='$top_dir'>\\n");
    EditFile.document.write("<input type=hidden name=dir value='$cur_url_dir'>\\n");
    EditFile.document.write("<input type=hidden name=operation value='Save changes'>\\n");
    
    
    EditFile.document.write("<h2>Editing the file: $url_filename</h2>\\n");
    EditFile.document.write("<table bgcolor='#FFFFFF' align=center width='90%'>\\n");
    EditFile.document.write("<tr align=center><td>\\n");
    EditFile.document.write("<textarea cols=60 rows=20 name=text>\\n");

HERE
      
      while(<RD>){
        $_ =~ s/\n/ /g;
        $_ =~ s/\r/ /g;
        $_ =~ s/\f/ /g;
        $_ =~ s/\t/ /g;
        $_ =~ s/\"/\\\"/g;
        if( $_ =~ s/^<\/script>// ){
          print "EditFile.document.writeln(\"<\/scr\")";
          print "EditFile.document.writeln(\"ipt>\\n\")";
          }else{
          print "EditFile.document.writeln(\"$_\");";
        }
      };
      
      close RD;
      
      print <<"HERE";
      
      EditFile.document.write("</textarea><P>\\n");
      EditFile.document.write("</td></tr>\\n");
      EditFile.document.write("</table>\\n");
      EditFile.document.write("<table bgcolor='#FFFFFF' width='100%'>\\n");
        EditFile.document.write("<tr align=center valign=center><td>\\n");
        
        EditFile.document.write("<a href=\\\"javascript:EditFile.document.editform.submit();\\\" target=FileListing \\n");
        EditFile.document.write("  onMouseOver=\\\"SaveFile.src='\/smgryap\/icons\/save-p.gif';\\\" \\n");
        EditFile.document.write("  onMouseOut=\\\"SaveFile.src='\/smgryap\/icons\/save.gif';\\\"><img name=SaveFile \\n");
        EditFile.document.write("  src=\\\"\/smgryap\/icons\/save.gif\\\" width=54 heigth=54 alt=\\\"Save edited file\\\" border=0><\/a> \\n");
        
        EditFile.document.write("<a href=\\\"javascript:window.close(self);\\\" \\n");
        EditFile.document.write("  onMouseOver=\\\"CloseEditor.src='\/smgryap\/icons\/closeeditor-p.gif';\\\" \\n");
        EditFile.document.write("  onMouseOut=\\\"CloseEditor.src='\/smgryap\/icons\/closeeditor.gif';\\\"><img name=CloseEditor \\n");
        EditFile.document.write("  src=\\\"\/smgryap\/icons\/closeeditor.gif\\\" width=54 heigth=54 alt=\\\"Close the editor\\\" border=0><\/a> \\n");
        
        
        EditFile.document.write("<\/td><\/tr>\\n");
        EditFile.document.write("<\/table>\\n");
        EditFile.document.write("<\/font>\\n");
        EditFile.document.write("<\/form>\\n<\/body>\\n<\/html>");
        
        EditFile.document.close();
        
        <\/script>
        <\/head>
        <\/html>
        
        
HERE
        return "<dt><font color=#0000FF><h2>Current action:<\/h2><\/font> <dd>Editing the file $url_filename. ";
        
        exit;
      }
      
      
      
#############################################################
      
      sub print_web_page {
        my ($user,$crpass,$DocumentRoot, $script_url, $prev_url_dir, $top_url_dir, $target_url_dir, $error_message,$operation) = @_;
        
        my $cur_url_dir = &get_sufix($target_url_dir,$DocumentRoot);
        
        if( $operation !~ /CREATE/ ){
          if( $operation !~ /EDIT/ ){
            print "Content-type: text/html\n\n";
          }
        }

###
### print page header
###
        if( $error_message =~ /failed/ && $operation !~ /MKDIR/ && $operation !~ /COPY/ && $operation !~ /MOVE/ && $operation !~ /Upload/ ){
          print "Content-type: text/html\n\n"; 
        }

        print <<"HERE";
<html>
<head>
<script language="JavaScript">
HERE
        ;
        
###
### print error message, if any
###
        
        if($error_message){
          print "parent.MsgWindow.document.open();\n";
          print "parent.MsgWindow.document.write(\"<html><body bgcolor=#FFFFFF>\");\n";
            print "parent.MsgWindow.document.write(\"$error_message\");\n";
            print "parent.MsgWindow.document.write(\"</body></html>\");\n";
            print "parent.MsgWindow.document.close();\n";
          }
          
          print <<"HERE";
          /*
          global variables for file or directory item selected
        and for the action selected (except upload))
        */
        var indexItemSelected = "";
        var actionSelected = "";
        
        /*
        onClick handler for radio buttons, recommeded for buggy NS 2.0
        item = url path to file or directory
        */
        function selectIndexItem(item) {
          
          this.document.mainform.selecteditem.value = item;
          indexItemSelected = item;
        }
        
        /*
        END OF JAVASCRIPT
        */
        
        </script>
        
        </head>
        <body bgcolor="#ddeedd" link="004400" vlink="006600">
        
        <blockquote>
        <dl>
        <form method=post action="$script_url" name="mainform">
        <input type=hidden name=selecteditem value="">
        <input type=hidden name=dir value="$cur_url_dir">
        <input type=hidden name=user value="$user">
        <input type=hidden name=crpass value="$crpass">
        
HERE
        ;                      ###### end of page header
        
###
### print directory index
###
        
# these local variables are used only in directory index
        my ($parent_url_dir, $target_fs_dir, $parent_fs_dir, $filename, $parent_fs_dir,
        @stat, $mtime, $size, $img, $comment, $fs_prefix, $url_prefix);
        
# Is important to check that it is not a serious error; a hacker could be behind this errors ...
        
        if( $error_message !~ /Fallo grave/ ) {
          
          print <<"HERE";
          
          <dt>\n<H2>Current directory file listing: $cur_url_dir/</H2>
          <hr>
          <dd>\n\n<table>
          
          <tr align=center>
          <td><b>Selection</b></td>
          <td></td>
          <td><b>Name</b></td>
          <td><b>Size</b></td>
          <td><b>Created</b></td>
          <td align=left><b>Type</b></td>
          </tr>
          
HERE
;
          
          
### if target dir is strictly below top
          
          if ( $target_url_dir =~ /^$top_url_dir.+/ ) {
            
            ($parent_url_dir = $target_url_dir) =~ s/\/[\w-\.~]+$//;
            ($parent_fs_dir = $target_dir) =~ s/\/[\w-\.~]+$//;
            
            print <<"HERE";
            
            <tr><td colspan=6>
            <input type=hidden name=parent_dir value="$parent_url_dir">
            <input type=submit name=prevdir value="up one directory"></td>
HERE
            ;
          }
# translate to file system paths
          
          $target_fs_dir = $target_url_dir;
          
### cycle through the files in the directory
          unless ( opendir DIR, $target_fs_dir ) {
            print "</table><dt><h2>Internal error:</h2>
            <dd>Please, send this text to the webmaster for seeing whats happening. 'opendir' failed: <ul>
	    <li>DocumentRoot: $DocumentRoot...
	    <li>HostName: $HostName...
	    <li>AuthSiteMgrURL: $AuthSiteMgrURL...
            <li>script_url: $script_url...
            <li>top_url_dir: $top_url_dir...
	    <li>top_fs_dir: $top_fs_dir...
            <li>parent_url_dir: $parent_url_dir
            <li>target_url_dir: $target_url_dir...
            <li>target_fs_dir: $target_fs_dir
            <li>error_message: $error_message...
            </ul>Environment variables: <ul>";
            foreach (keys %ENV) {
              print "<li>$_: $ENV{$_}\n";
            }
            print "</ul></dl></blockquote></body></html>";
            exit;
          }

          my @all_files_and_directories = readdir DIR;
 
          my @all_directories;
          my @all_files;
 
          for $filename (@all_files_and_directories) {
            @stat = stat $target_fs_dir.'/'.$filename;
 
            if (-d _) {
              unshift @all_directories , $filename;
            } else {
              unshift @all_files , $filename;
            }
          }
 
# All directories and files are sorted
 
         my @all_directories_sorted = sort @all_directories;
         my @all_files_sorted = sort @all_files;
 
# Directories will appear first
 
         my @all_sorted_directories_first ;
 
         push @all_sorted_directories_first , @all_directories_sorted;
         push @all_sorted_directories_first , @all_files_sorted;
 
# Let's print out all the directory listing
 
         for $filename (@all_sorted_directories_first) {
            
            next if $filename eq ".";  # skip hidden files
            next if $filename eq "..";
            
            @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 <<"HERE";
              <tr><td align=center>
              <input type=radio name=item value=\"$cur_url_dir/$filename\"
              onClick=selectIndexItem(\"$cur_url_dir/$filename\")> </td>
              <td> <IMG ALIGN=absbottom BORDER=0 SRC=\"\/smgryap\/icons\/folder.gif\"> </td>
              <td> <input type=submit name=subdir value="$filename"><br> </td>
              <td align=right>$size bytes</td>
              <td>$mtime </td>
              <td>Directory</td></tr>\n
HERE
              ;
              next;
            }
            
            if ($filename =~ /\.html?$/i) {     # .htm or .html file (not dir)
              $img = "\/smgryap\/icons\/html.gif";
              $comment = "HTML file";
              } elsif ($filename =~  /\.gif/i or $filename =~ /\.jpg/i or $filename =~ /\.png/i) { # gif, jpg, or png
              $img = "\/smgryap\/icons\/image.gif";
              $comment = "Image";
	      } elsif ($filename =~  /\.mov/i or $filename =~ /\.avi/i or $filename =~ /\.mpg/i) { # video formats 
	      $img = "\/smgryap\/icons\/video.gif";
	      $comment = "Video"; 
              } elsif ($filename =~  /\.txt/i) { # .txt file
              $img = "\/smgryap\/icons\/text.gif";
              $comment = "Text file";
              } else {
              $img = "\/smgryap\/icons\/unknown.gif";
              $comment = "Unknown format";
            }
            
            print <<"HERE";
            <tr><td align=center>
            <input type=radio name=item value=\"$cur_url_dir/$filename\"
            onClick=selectIndexItem(\"$cur_url_dir/$filename\")> </td>
            <td> <IMG ALIGN=absbottom BORDER=0 SRC=\"$img\"></td>
            <td><a href=\"/$cur_url_dir/$filename\" target=_blank>$filename</a></td>
            <td align=right>$size bytes</td>
            <td>$mtime </td>
            <td>$comment </td></tr>\n
HERE
            ;
          }                           ### end of while
          closedir DIR;
          print "</table>\n";              #######  end of print directory index
          
###
### print_file_operations
###
          print <<"HERE";
          
          <input type=hidden name=newName value="$cur_url_dir/" size=50>
          <input type=hidden name=operation value="NO_OP">
          
          <input type=hidden name=top_dir value=$top_dir>
          
          </form>                               <!-- still in blockquote and dl -->
          
          <form method=post action="$script_url"
          name="uploadForm"
          onSubmit="return checkUploadForm()"
          enctype="multipart/form-data">
          
          <input type=hidden name=user value="$user">
          <input type=hidden name=crpass value="$crpass">
          <input type=hidden name=top_dir value="$top_dir">
          <input type=hidden name=dir value="$cur_url_dir">
          
          <input type=hidden name=remoteUploadName size=50>
          <input type=hidden name=newUploadName>
          <input type=hidden name=operation value="Upload file">
          </form>
          </blockquote>
          <hr>
HERE
          ;       ############## End of print directory index
          
        }           ############## End of 'Serious fail' exclusion
        
        print "\n<\/body>\n<\/html>";
        
      }           ############## End of sub print_web_page
      
      
##########################################################
#
# gets the sufix (right hand side) of a url giving the root
#
      
      sub get_sufix()
      {
        my ($complete_url,$doc_root) = @_;
        
        my $new_url = $complete_url;
        
        $new_url =~ s/$doc_root//;
        
        return $new_url;
      }