--- loncom/publisher/loncfile.pm 2002/06/07 01:35:48 1.11
+++ loncom/publisher/loncfile.pm 2011/11/02 19:12:40 1.113
@@ -8,9 +8,8 @@
# and requests confirmation. The second phase commits the action
# and displays a page showing the results of the action.
#
-
#
-# $Id: loncfile.pm,v 1.11 2002/06/07 01:35:48 albertel Exp $
+# $Id: loncfile.pm,v 1.113 2011/11/02 19:12:40 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -34,90 +33,307 @@
#
# http://www.lon-capa.org/
#
-#
-# (Handler to retrieve an old version of a file
-#
-# (Publication Handler
-#
-# (TeX Content Handler
-#
-# 05/29/00,05/30,10/11 Gerd Kortemeyer)
-#
-# 11/28,11/29,11/30,12/01,12/02,12/04,12/23 Gerd Kortemeyer
-# 03/23 Guy Albertelli
-# 03/24,03/29 Gerd Kortemeyer)
-#
-# 03/31,04/03,05/02,05/09,06/23,06/24 Gerd Kortemeyer)
-#
-# 06/23 Gerd Kortemeyer
-# 05/07/02 Ron Fox:
-# - Added Debug log output so that I can trace what the heck this
-# undocumented thingy does.
+=pod
+
+=head1 NAME
+
+Apache::loncfile - Construction space file management.
+
+=head1 SYNOPSIS
+
+ Content handler for buttons on the top frame of the construction space
+directory.
+
+=head1 INTRODUCTION
+
+ loncfile is invoked when buttons in the top frame of the construction
+space directory listing are clicked. All operations proceed in two phases.
+The first phase describes to the user exactly what will be done. If the user
+confirms the operation, the second phase commits the operation and indicates
+completion. When the user dismisses the output of phase2, they are returned to
+an "appropriate" directory listing in general.
+
+ This is part of the LearningOnline Network with CAPA project
+described at http://www.lon-capa.org.
+
+=head2 Subroutines
+
+=cut
package Apache::loncfile;
use strict;
use Apache::File;
+use File::Basename;
use File::Copy;
+use HTML::Entities();
use Apache::Constants qw(:common :http :methods);
use Apache::loncacc;
-use Apache::Log ();
+use Apache::lonnet;
+use Apache::loncommon();
+use Apache::lonlocal;
+use LONCAPA qw(:DEFAULT :match);
+
my $DEBUG=0;
my $r; # Needs to be global for some stuff RF.
-#
-# Debug
-# If debugging is enabled puts out a debuggin message determined by the
-# caller. The debug message goes to the Apache error log file.
-#
-# Parameters:
-# r - Apache request [in]
-# message - String [in]
-# Returns:
-# nothing.
+
+=pod
+
+=item Debug($request, $message)
+
+ If debugging is enabled puts out a debugging message determined by the
+ caller. The debug message goes to the Apache error log file. Debugging
+ is enabled by setting the module global DEBUG variable to nonzero (TRUE).
+
+ Parameters:
+
+=over 4
+
+=item $request - The current request operation.
+
+=item $message - The message to put in the log file.
+
+=back
+
+ Returns:
+ nothing.
+
+=cut
+
sub Debug {
- my $r = shift;
- my $log = $r->log;
- my $message = shift;
+ # Put out the indicated message butonly if DEBUG is true.
if ($DEBUG) {
- $log->debug($message);
+ my ($r,$message) = @_;
+ $r->log_reason($message);
}
}
-#
-# URLToPath
-# Convert a URL to a file system path.
-#
-# In order to manipulate the construction space objects, it's necessary
-# to access url identified objects a filespace objects. This function
-# translates a construction space URL to a file system path.
-# Parameters:
-# Url - string [in] The url to convert.
-# Returns:
-# The corresponing file system path.
-sub URLToPath
-{
+
+sub done {
+ my ($url)=@_;
+ my $done=&mt("Done");
+ return(<$done
+
+ENDDONE
+}
+
+=pod
+
+=item URLToPath($url)
+
+ Convert a URL to a file system path.
+
+ In order to manipulate the construction space objects, it is necessary
+ to access url identified objects a filespace objects. This function
+ translates a construction space URL to a file system path.
+ Parameters:
+
+=over 4
+
+=item Url - string [in] The url to convert.
+
+=back
+
+ Returns:
+
+=over 4
+
+=item The corresponding file system path.
+
+=back
+
+Global References
+
+=over 4
+
+=item $r - Request object [in] Referenced in the &Debug calls.
+
+=back
+
+=cut
+
+sub URLToPath {
my $Url = shift;
&Debug($r, "UrlToPath got: $Url");
- $Url=~ s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/;
- $Url=~ s/^http\:\/\/[^\/]+//;
+ $Url=~ s{^https?\://[^/]+}{};
+ $Url=~ s{//+}{/}g;
+ $Url=~ s{^/}{};
+ $Url=$Apache::lonnet::perlvar{'lonDocRoot'}."/$Url";
&Debug($r, "Returning $Url \n");
return $Url;
}
-sub exists {
- my ($uname,$udom,$dir,$newfile)=@_;
- my $published='/home/httpd/html/res/'.$udom.'/'.$uname.'/'.$dir.'/'.
- $ENV{'form.newfilename'};
- my $construct='/home/'.$uname.'/public_html/'.$dir.'/'.
- $ENV{'form.newfilename'};
- my $result;
+
+sub url {
+ my $fn=shift;
+ my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
+ $fn=~ s/^\Q$londocroot\E//;
+ $fn=~s{/\./}{/}g;
+ $fn=&HTML::Entities::encode($fn,'<>"&');
+ return $fn;
+}
+
+sub display {
+ my $fn=shift;
+ my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
+ $fn=~s/^\Q$londocroot\E//;
+ $fn=~s{/\./}{/}g;
+ return ''.$fn.'';
+}
+
+
+# see if the file is
+# a) published (return 0 if not)
+# b) if, so obsolete (return 0 if not)
+
+sub obsolete_unpub {
+ my ($user,$domain,$construct)=@_;
+ my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
+ my $published=$construct;
+ $published=~s{^\Q$londocroot/priv/\E}{$londocroot/res/};
if (-e $published) {
- $result.='
Warning: target file exists, and has been published!
';
- } elsif ( -e $construct ) {
- $result.='
Warning: target file exists!
';
+ if (&Apache::lonnet::metadata($published,'obsolete')) {
+ return 1;
+ }
+ return 0;
+ } else {
+ return 1;
}
- return $result;
}
+# see if directory is empty
+# ignores any .meta, .save, .bak, and .log files created for a previously
+# published file, which has since been marked obsolete and deleted.
+sub empty_directory {
+ my ($dirname,$phase) = @_;
+ if (opendir DIR, $dirname) {
+ my @files = grep(!/^\.\.?$/, readdir(DIR)); # ignore . and ..
+ if (@files) {
+ my @orphans = grep(/\.(meta|save|log|bak)$/,@files);
+ if (scalar(@files) - scalar(@orphans) > 0) {
+ return 0;
+ } else {
+ if (($phase eq 'Delete2') && (@orphans > 0)) {
+ foreach my $file (@orphans) {
+ if ($file =~ /\.(meta|save|log|bak)$/) {
+ unlink($dirname.$file);
+ }
+ }
+ }
+ }
+ }
+ closedir(DIR);
+ return 1;
+ }
+ return 0;
+}
+
+=pod
+
+=item exists($user, $domain, $file)
+
+ Determine if a resource file name has been published or exists
+ in the construction space.
+
+ Parameters:
+
+=over 4
+
+=item $user - string [in] - Name of the user for which to check.
+
+=item $domain - string [in] - Name of the domain in which the resource
+ might have been published.
+
+=item $file - string [in] - Name of the file.
+
+=item $creating - string [in] - optional, type of object being created,
+ either 'directory' or 'file'. Defaults to
+ 'file' if unspecified.
+
+=back
+
+Returns:
+
+=over 4
+
+=item string - Either undef, 'warning' or 'error' depending on the
+ type of problem
+
+=item string - Either where the resource exists as an html string that can
+ be embedded in a dialog or an empty string if the resource
+ does not exist.
+
+=back
+
+=cut
+
+sub exists {
+ my ($user, $domain, $construct, $creating) = @_;
+ $creating ||= 'file';
+
+ my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
+ my $published=$construct;
+ $published=~s{^\Q$londocroot/priv/\E}{$londocroot/res/};
+ my ($type,$result);
+ if ( -d $construct ) {
+ return ('error','
'.&mt('Error: destination for operation is an existing directory.').'
';
+ }
+
+ return ($type,$result);
+}
+
+=pod
+
+=item checksuffix($old, $new)
+
+ Determine if a resource filename suffix (the stuff after the .) would change
+as a result of this operation.
+
+ Parameters:
+
+=over 4
+
+=item $old = string [in] Previous filename.
+
+=item $new = string [in] Resultant filename.
+
+=back
+
+ Returns:
+
+=over 4
+
+=item Empty string if everything worked.
+
+=item String containing an error message if there was a problem.
+
+=back
+
+=cut
+
sub checksuffix {
my ($old,$new) = @_;
my $result;
@@ -125,260 +341,1213 @@ sub checksuffix {
my $newsuffix;
if ($new=~m:(.*/*)([^/]+)\.(\w+)$:) { $newsuffix=$3; }
if ($old=~m:(.*)/+([^/]+)\.(\w+)$:) { $oldsuffix=$3; }
- if ($oldsuffix ne $newsuffix) {
- $result.='
Warning: change of MIME type!
';
+ if (lc($oldsuffix) ne lc($newsuffix)) {
+ $result.=
+ '
'.&mt('Warning: change of MIME type!').'
';
}
return $result;
}
-sub phaseone {
- my ($r,$fn,$uname,$udom)=@_;
+sub cleanDest {
+ my ($request,$dest,$subdir,$fn,$uname,$udom)=@_;
+ #remove bad characters
+ my $foundbad=0;
+ my $error='';
+ if ($subdir && $dest =~/\./) {
+ $foundbad=1;
+ $dest=~s/\.//g;
+ }
+ $dest =~ s/(\s+$|^\s+)//g;
+ if ($dest=~/[\#\?&%\":]/) {
+ $foundbad=1;
+ $dest=~s/[\#\?&%\":]//g;
+ }
+ if ($dest=~m|/|) {
+ my ($newpath)=($dest=~m|(.*)/|);
+ ($newpath,$error)=&relativeDest($fn,$newpath,$uname,$udom);
+ if (! -d "$newpath") {
+ $request->print('
'
+ .&mt("You have requested to create file in directory [_1] which doesn't exist. The requested directory path has been removed from the requested file name."
+ ,&display($newpath))
+ .'
'
+ .&mt('No such file: [_1]',
+ &display($fn))
+ .'
'
+ );
+ }
+}
+
+=pod
+
+=item NewDir1
+
+ Does all phase 1 processing of directory creation:
+ Ensures that the user provides a new directory name,
+ and that the directory does not already exist.
+
+Parameters:
+
+=over 4
+
+=item $request - Apache Request Object [in] - Server request object for the
+ current url.
+
+=item $username - Name of the user that is requesting the directory creation.
+
+=item $domain - Domain user is in
+
+=item $fn - source file.
+
+=item $newdir - Name of the directory to be created; path relative to the
+ top level of construction space.
+=back
+
+Side Effects:
+
+=over 4
+
+=item A new form is displayed. Clicking on the confirmation button
+causes the newdir operation to transition into phase 2. The hidden field
+"newfilename" is set with the construction space path to the new directory.
+
+
+=back
+
+=cut
+
+
+sub NewDir1 {
+ my ($request, $username, $domain, $fn, $newfilename, $mode) = @_;
+
+ my ($type, $result)=&exists($username,$domain,$newfilename,'directory');
+ $request->print($result);
+ if ($type eq 'error') {
+ $request->print('');
+ } else {
+ if (($mode eq 'testbank') || ($mode eq 'imsimport')) {
+ $request->print(''."\n".
+ '');
+ }
+ $request->print(''
+ .'
'
+ .&mt('Make new directory [_1]?',
+ &display($newfilename))
+ .'
'
+ .&mt('No such file: [_1]',
+ &display($fn))
+ .'
'
+ );
+ }
+}
+
+=pod
+
+=item NewFile1
+
+ Does all phase 1 processing of file creation:
+ Ensures that the user provides a new filename, adds proper extension
+ if needed and that the file does not already exist, if it is a html,
+ problem, page, or sequence, it then creates a form link to hand the
+ actual creation off to the proper handler.
+
+Parameters:
+
+=over 4
+
+=item $request - Apache Request Object [in] - Server request object for the
+ current url.
+
+=item $username - Name of the user that is requesting the directory creation.
+
+=item $domain - Name of the domain of the user
+
+=item $fn - Source file name
+
+=item $newfilename
+ - Name of the file to be created; no path information
+=back
+
+Side Effects:
+
+=over 4
+
+=item 2 new forms are displayed. Clicking on the confirmation button
+causes the browser to attempt to load the specfied URL, allowing the
+proper handler to take care of file creation. There is also a Cancel
+button which returns you to the driectory listing you came from
+
+=back
+
+=cut
+
+sub NewFile1 {
+ my ($request, $user, $domain, $fn, $newfilename) = @_;
+ return if (&filename_check($newfilename) ne 'ok');
+
+ if ($env{'form.action'} =~ /new(.+)file/) {
+ my $extension=$1;
+ if ($newfilename !~ /\Q.$extension\E$/) {
+ if ($newfilename =~ m|/[^/.]*\.(?:[^/.]+)$|) {
+ #already has an extension strip it and add in expected one
+ $newfilename =~ s|(/[^./])\.(?:[^.]+)$|$1|;
}
- } else {
- $r->print('
'.
+ &mt('The name of the new file needs to end with an appropriate file extension to indicate the type of file to create.').' '.
+ &mt('The following are valid extensions: [_1].',$validexts).
+ '
'.
+ '
'.
+ '');
return;
}
- $r->print('
Make new directory '.
- $fn.$ENV{'form.newfilename'}.'?
'.&mt('Make new file').' '.&display($newfilename).'?
');
+ $request->print('');
+
+ $request->print('');
+ $request->print('');
+ }
+ return;
}
-sub phasetwo {
- my ($r,$fn,$uname,$udom)=@_;
+sub filename_check {
+ my ($newfilename) = @_;
+ ##Informs User (name).(number).(extension) not allowed
+ if($newfilename =~ /\.(\d+)\.(\w+)$/){
+ $r->print(''.$newfilename.
+ ' - '.&mt('Bad Filename').' ('.&mt('name').').('.&mt('number').').('.&mt('extension').') '.
+ ' '.&mt('Not Allowed').'');
+ return;
+ }
+ if($newfilename =~ /(\:\:\:|\&\&\&|\_\_\_)/){
+ $r->print(''.$newfilename.
+ ' - '.&mt('Bad Filename').' ('.&mt('Must not include').' '.$1.') '.
+ ' '.&mt('Not Allowed').'');
+ return;
+ }
+ return 'ok';
+}
- &Debug($r, "loncfile - Entering phase 2 for $fn");
+=pod
- $fn=~/(.*)\/([^\/]+)\.(\w+)$/;
- my $dir=$1;
- my $main=$2;
- my $suffix=$3;
- $dir =~ s-^/[^/]*/[^/]*/[^/]*--;
-
-
- &Debug($r, "loncfile::phase2 dir = $dir main = $main suffix = $suffix");
+=item phaseone($r, $fn, $uname, $udom)
- my $conspace=$fn;
+ Peforms phase one processing of the request. In phase one, error messages
+are returned if the request cannot be performed (e.g. attempts to manipulate
+files that are nonexistent). If the operation can be performed, what is
+about to be done will be presented to the user for confirmation. If the
+user confirms the request, then phase two is executed, the action
+performed and reported to the user.
- &Debug($r, "loncfile::phase2 Full construction space name: $conspace");
+ Parameters:
- &Debug($r, "loncfie::phase2 action is $ENV{'form.action'}");
+=over 4
- if ($ENV{'form.action'} eq 'rename') {
- if (-e $conspace) {
- if ($ENV{'form.newfilename'}) {
- unless (rename($fn,
- '/home/'.$uname.'/public_html'.$dir.'/'.$ENV{'form.newfilename'})) {
- $r->print('Error: '.$!.'');
- }
- }
- } else {
- $r->print('
No such file.');
- return;
- }
- } elsif ($ENV{'form.action'} eq 'delete') {
- if (-e $conspace) {
- unless (unlink($fn)) {
- $r->print('Error: '.$!.'');
- }
+=item $r - request object [in] - The Apache request being executed.
+
+=item $fn = string [in] - The filename being manipulated by the
+ request.
+
+=item $uname - string [in] Name of user logged in and doing this action.
+
+=item $udom - string [in] Domain name under which the user logged in.
+
+=back
+
+=cut
+
+sub phaseone {
+ my ($r,$fn,$uname,$udom)=@_;
+
+ my $doingdir=0;
+ if ($env{'form.action'} eq 'newdir') { $doingdir=1; }
+ my ($newfilename,$error) =
+ &cleanDest($r,$env{'form.newfilename'},$doingdir,$fn,$uname,$udom);
+ unless ($error) {
+ ($newfilename,$error)=&relativeDest($fn,$newfilename,$uname,$udom);
+ }
+ if ($error) {
+ my $dirlist;
+ if ($fn=~m{^(.*/)[^/]+$}) {
+ $dirlist=$1;
} else {
- $r->print('
No such file.');
- return;
+ $dirlist=$fn;
}
- } elsif ($ENV{'form.action'} eq 'copy') {
- if (-e $conspace) {
- if ($ENV{'form.newfilename'}) {
- unless (copy($fn,
- '/home/'.$uname.'/public_html'.$dir.'/'.$ENV{'form.newfilename'})) {
- $r->print('Error: '.$!.'');
- }
+ $r->print('
'
+ );
+ }
+ }
+}
+
+=pod
+
+=item Rename2($request, $user, $directory, $oldfile, $newfile)
+
+Performs phase 2 processing of a rename reequest. This is where the
+actual rename is performed.
+
+Parameters
+
+=over 4
+
+=item $request - Apache request object [in] The request being processed.
+
+=item $user - string [in] The name of the user initiating the request.
+
+=item $directory - string [in] The name of the directory relative to the
+ construction space top level of the renamed file.
+
+=item $oldfile - Name of the file.
+
+=item $newfile - Name of the new file.
+
+=back
+
+Returns:
+
+=over 4
+
+=item 1 Success.
+
+=item 0 Failure.
+
+=cut
+
+sub Rename2 {
+
+ my ($request, $user, $directory, $oldfile, $newfile) = @_;
+
+ &Debug($request, "Rename2 directory: ".$directory." old file: ".$oldfile.
+ " new file ".$newfile."\n");
+ &Debug($request, "Target is: ".$directory.'/'.
+ $newfile);
+ if (-e $oldfile) {
+
+ my $oRN=$oldfile;
+ my $nRN=$newfile;
+ unless (rename($oldfile,$newfile)) {
+ $request->print(''.&mt('Error').': '.$!.'');
+ return 0;
+ }
+ ## If old name.(extension) exits, move under new name.
+ ## If it doesn't exist and a new.(extension) exists
+ ## delete it (only concern when renaming over files)
+ my $tmp1=$oRN.'.meta';
+ my $tmp2=$nRN.'.meta';
+ if(-e $tmp1){
+ unless(rename($tmp1,$tmp2)){ }
+ } elsif(-e $tmp2){
+ unlink $tmp2;
+ }
+ $tmp1=$oRN.'.save';
+ $tmp2=$nRN.'.save';
+ if(-e $tmp1){
+ unless(rename($tmp1,$tmp2)){ }
+ } elsif(-e $tmp2){
+ unlink $tmp2;
+ }
+ $tmp1=$oRN.'.log';
+ $tmp2=$nRN.'.log';
+ if(-e $tmp1){
+ unless(rename($tmp1,$tmp2)){ }
+ } elsif(-e $tmp2){
+ unlink $tmp2;
+ }
+ $tmp1=$oRN.'.bak';
+ $tmp2=$nRN.'.bak';
+ if(-e $tmp1){
+ unless(rename($tmp1,$tmp2)){ }
+ } elsif(-e $tmp2){
+ unlink $tmp2;
+ }
+ } else {
+ $request->print(
+ '
'
+ .&mt('No such file: [_1]',
+ &display($oldfile))
+ .'
'
+ );
+ return 0;
+ }
+ return 1;
+}
+
+=pod
+
+=item Delete2($request, $user, $filename)
+
+ Performs phase two of a delete. The user has confirmed that they want
+to delete the selected file. The file is deleted and the results of the
+delete attempt are indicated.
+
+Parameters:
+
+=over 4
+
+=item $request - Apache Request object [in] the request object for the current
+ delete operation.
+
+=item $user - string [in] The name of the user initiating the delete
+ request.
+
+=item $filename - string [in] The name of the file, relative to construction
+ space, to delete.
+
+=back
+
+Returns:
+ 1 - success.
+ 0 - Failure.
+
+=cut
+
+sub Delete2 {
+ my ($request, $user, $filename) = @_;
+ if (-d $filename) {
+ unless (&empty_directory($filename,'Delete2')) {
+ $request->print(''.&mt('Error: Directory Non Empty').'');
+ return 0;
+ } else {
+ if(-e $filename) {
+ unless(rmdir($filename)) {
+ $request->print(''.&mt('Error').': '.$!.'');
+ return 0;
+ }
} else {
- $r->print('
No new filename specified.');
- return;
+ $request->print('