--- loncom/publisher/loncfile.pm 2003/01/09 22:11:52 1.21
+++ loncom/publisher/loncfile.pm 2011/10/24 22:39:21 1.111
@@ -7,10 +7,9 @@
# presents a page that describes the proposed action to the user
# and requests confirmation. The second phase commits the action
# and displays a page showing the results of the action.
-#
-
#
-# $Id: loncfile.pm,v 1.21 2003/01/09 22:11:52 albertel Exp $
+#
+# $Id: loncfile.pm,v 1.111 2011/10/24 22:39:21 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -34,27 +33,6 @@
#
# 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.
-# 05/28/02 Ron Fox:
-# - Started putting in pod in standard format.
=pod
=head1 NAME
@@ -91,8 +69,11 @@ 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.
@@ -121,18 +102,22 @@ my $r; # Needs to be global for some
=cut
sub Debug {
-
- # Marshall the parameters.
-
- my $r = shift;
- my $log = $r->log;
- my $message = shift;
-
- # Put out the indicated message butonly if DEBUG is false.
-
- if ($DEBUG) {
- $log->debug($message);
- }
+ # Put out the indicated message butonly if DEBUG is true.
+ if ($DEBUG) {
+ my ($r,$message) = @_;
+ $r->log_reason($message);
+ }
+}
+
+sub done {
+ my ($url)=@_;
+ my $done=&mt("Done");
+ return(<$done
+
+ENDDONE
}
=pod
@@ -171,122 +156,80 @@ Global References
=cut
sub URLToPath {
- my $Url = shift;
- &Debug($r, "UrlToPath got: $Url");
- $Url=~ s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/;
- $Url=~ s/^http\:\/\/[^\/]+//;
- &Debug($r, "Returning $Url \n");
- return $Url;
+ my $Url = shift;
+ &Debug($r, "UrlToPath got: $Url");
+ $Url=~ s/\/+/\//g;
+ $Url=~ s/^https?\:\/\/[^\/]+//;
+ $Url=~ s/^\///;
+ $Url='/home/httpd/html/'.$Url;
+ &Debug($r, "Returning $Url \n");
+ return $Url;
+}
+
+sub url {
+ my $fn=shift;
+ $fn=~s/^\/home\/httpd\/html//;
+ $fn=~s/\/\.\//\//g;
+ $fn=&HTML::Entities::encode($fn,'<>"&');
+ return $fn;
+}
+
+sub display {
+ my $fn=shift;
+ $fn=~s/^\/home\/httpd\/html//;
+ $fn=~s/\/\.\//\//g;
+ return ''.$fn.'';
}
-=pod
-
-=item PublicationPath($domain, $user, $dir, $file)
-
- Determines the filesystem path corresponding to a published resource
- specification. The returned value is the path.
-Parameters:
-
-=over 4
-
-=item $domain - string [in] Name of the domain within which the resource is
- stored.
-
-=item $user - string [in] Name of the user asking about the resource.
-
-=item $dir - Directory path relative to the top of the resource space.
-
-=item $file - name of the resource file itself without path info.
-
-=back
-
-=over 4
-
-Returns:
-
-=item string - full path to the file if it exists in publication space.
-
-=back
-
-=cut
-
-sub PublicationPath
-{
- my ($domain, $user, $dir, $file)=@_;
-
- return '/home/httpd/html/res/'.$domain.'/'.$user.'/'.$dir.'/'.
- $file;
-}
-
-=pod
-
-=item ConstructionPath($domain, $user, $dir, $file)
-
- Determines the filesystem path corresponding to a construction space
- resource specification. The returned value is the path
-Parameters:
-
-=over 4
-
-=item $user - string [in] Name of the user asking about the resource.
-
-=item $dir - Directory path relative to the top of the resource space.
-
-=item $file - name of the resource file itself without path info.
-
-Returns:
-
-=item string - full path to the file if it exists in Construction space.
-
-=back
-
-=cut
-
-sub ConstructionPath {
- my ($user, $dir, $file) = @_;
-
- return '/home/'.$user.'/public_html/'.$dir.'/'.$file;
+# 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 $published=$construct;
+ $published=~s/^\/home\/httpd\/html\/priv\//\/home\/httpd\/html\/res\//;
+ if (-e $published) {
+ if (&Apache::lonnet::metadata($published,'obsolete')) {
+ return 1;
+ }
+ return 0;
+ } else {
+ return 1;
+ }
}
-=pod
-
-=item ConstructionPathFromRelative($user, $relname)
-
- Determines the path to a construction space file given
-the username and the path relative to the root of construction space.
-
-Parameters:
-
-=over 4
-
-=item $user - string [in] Name of the user in whose construction space the
- file [will] live.
-
-=item $relname - string[in] Path to the file relative to the root of the
- construction space.
-
-=back
-
-Returns:
-
-=over 4
-
-=item string - Full path to the file.
-
-=back
-
-=cut
-
-sub ConstructionPathFromRelative {
-
- my ($user, $relname) = @_;
- return '/home/'.$user.'/public_html'.$relname;
+# 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, $directory, $file)
+=item exists($user, $domain, $file)
Determine if a resource file name has been published or exists
in the construction space.
@@ -295,15 +238,16 @@ sub ConstructionPathFromRelative {
=over 4
-=item $user - string [in] - Name of the user for which to check.
+=item $user - string [in] - Name of the user for which to check.
-=item $domain - string [in] - Name of the domain in which the resource
+=item $domain - string [in] - Name of the domain in which the resource
might have been published.
-=item $dir - string [in] - Path relative to construction or resource space
- in which the resource might live.
+=item $file - string [in] - Name of the file.
-=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
@@ -311,6 +255,9 @@ 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.
@@ -320,30 +267,38 @@ Returns:
=cut
sub exists {
- my ($user, $domain, $dir, $file) = @_;
+ my ($user, $domain, $construct, $creating) = @_;
+ $creating ||= 'file';
- # Create complete paths in publication and construction space.
- my $relativedir=$dir;
- $relativedir=s|/home/\Q$user\E/public_html||;
- my $published = &PublicationPath($domain, $user, $relativedir, $file);
- my $construct = &ConstructionPath($user, $relativedir, $file);
-
- # If the resource exists in either space indicate this fact.
- # Note that the check for existence in resource space is stricter.
-
- my $result;
- if ( -d $construct ) {
- return 'Error: destination for operation is a directory.';
- }
- if ( -e $published) {
- $result.='
Warning: target file exists, and has been published!
';
- }
- elsif ( -e $construct) {
- $result.='
Warning: target file exists!
';
- }
+ my $published=$construct;
+ $published=~s{^/home/httpd/html/priv/}{/home/httpd/html/res/};
+ my ($type,$result);
+ if ( -d $construct ) {
+ return ('error','
'.&mt('Error: destination for operation is an existing directory.').'
';
+ }
+
+ return ($type,$result);
}
=pod
@@ -382,12 +337,80 @@ sub checksuffix {
my $newsuffix;
if ($new=~m:(.*/*)([^/]+)\.(\w+)$:) { $newsuffix=$3; }
if ($old=~m:(.*)/+([^/]+)\.(\w+)$:) { $oldsuffix=$3; }
- if ($oldsuffix ne $newsuffix) {
+ if (lc($oldsuffix) ne lc($newsuffix)) {
$result.=
- '
Warning: change of MIME type!
';
+ '
'.&mt('Warning: change of MIME type!').'
';
}
return $result;
}
+
+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))
+ .'
'
+ );
return;
}
}
+
=pod
=item Delete1
@@ -529,35 +591,60 @@ Parameters:
=over 4
-=item $request - Apache Request Object [in] request object for the current
+=item $request - Apache Request Object [in] request object for the current
request.
-=item $user - string [in] Name of session user.
+=item $user - string [in] Name of the user initiating the request.
+=item $domain - string [in] Domain the initiating user is logged in as
-=item $filename - string [in] Name fo the file to be deleted:
- Filename is the full filesystem path to the file.
+=item $filename - string [in] Source filename.
=back
=cut
sub Delete1 {
- my ($request, $user, $filename) = @_;
-
- my $cancelurl = '/priv/'.$filename;
- $cancelurl =~ s/\/home\///;
- $cancelurl =~ s/\/public_html//;
-
+ my ($request, $user, $domain, $fn) = @_;
- if( -e $filename) {
- $request->print('');
- $request->print('
');
- }
}
=pod
-=item SimplifyDir
-
- Removes all extra / and all .. references
+=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 $dir - string [in] a directory name
+=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 $file - string [in] a file reference relative to $dir
+=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
-Results: the concatenated path.
+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 SimplifyDir {
- my ($dir,$file) = @_;
- my $location = $dir. '/'.$file;
- $location=~s://+:/:g; # remove duplicate /
- while ($location=~m:/\.\./:) {$location=~s:/[^/]+/\.\./:/:g;}#remove dir/..
- return $location;
+
+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 NewDir1
+=item NewFile1
- 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.
+ 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:
@@ -661,47 +817,97 @@ Parameters:
=item $username - Name of the user that is requesting the directory creation.
-=item $path - current directory relative to construction space.
+=item $domain - Name of the domain of the user
-=item $newdir - Name of the directory to be created; path relative to the
- top level of construction space.
+=item $fn - Source file name
+
+=item $newfilename
+ - Name of the file to be created; no path information
=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.
-
+=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|;
+ }
+ $newfilename.=".$extension";
+ }
+ }
+ my ($type, $result)=&exists($user,$domain,$newfilename);
+ $request->print($result);
+ if ($type eq 'error') {
+ $request->print('');
+ } else {
+ my $extension;
-sub NewDir1
-{
- my ($request, $username, $path, $newdir) = @_;
-
- my $fullpath = '/home/'.$username.'/public_html/'.
- $path.'/'.$newdir;
-
- my $cancelurl = '/priv/'.$username.'/'.$path;
-
- &Debug($request, "Full path is : ".$fullpath);
-
- if(-e $fullpath) {
- $request->print('
Directory exists.
');
- }
- else {
- $request->print('
Make new directory '.
- $path."/".$newdir.'?
');
- &CloseForm1($request, $cancelurl);
+ if ($newfilename =~ m{[^/.]+\.([^/.]+)$}) {
+ $extension = $1;
+ }
+
+ my @okexts = qw(xml html xhtml htm xhtm problem page sequence rights sty task library js css txt);
+ if (($extension eq '') || (!grep(/^\Q$extension\E/,@okexts))) {
+ my $validexts = '.'.join(', .',@okexts);
+ $request->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;
+ }
+
+ $request->print('
'.&mt('Make new file').' '.&display($newfilename).'?
');
+ $request->print('');
+
+ $request->print('');
+ $request->print('');
+ }
+ return;
+}
- }
+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';
}
=pod
@@ -733,40 +939,75 @@ performed and reported to the user.
=cut
sub phaseone {
- my ($r,$fn,$uname,$udom)=@_;
-
- $fn=~m:(.*)/([^/]+)\.(\w+)$:;
- my $dir=$1;
- my $main=$2;
- my $suffix=$3;
-
- # my $conspace=ConstructionPathFromRelative($uname, $fn);
-
-
- $r->print('');
- }
- } elsif ($ENV{'form.action'} eq 'newdir') {
- &NewDir1($r, $uname, $dir, $ENV{'form.newfilename'});
- }
+ 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 {
+ $dirlist=$fn;
+ }
+ $r->print('
');
+ } else {
+ $r->print(&done(&url($dest)));
+ }
}
- #
- # Substitute for priv for the first home in $dir to get our
- # construction space path.
- #
- &Debug($r, "Final url is: $dest");
- $dest =~ s|/home/|/priv/|;
- $dest =~ s|/public_html||;
-
- my $base = &File::Basename::basename($dest);
- my $dpath= &File::Basename::dirname($dest);
- if ($base eq '.') { $base=''; }
- $dest = &HTML::Entities::encode($dpath.'/'.$base);
-
-
- &Debug($r, "Final url after rewrite: $dest");
-
- $r->print('