--- loncom/publisher/loncfile.pm 2002/09/02 20:06:57 1.17
+++ loncom/publisher/loncfile.pm 2011/11/14 00:20:31 1.114
@@ -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.17 2002/09/02 20:06:57 harris41 Exp $
+#
+# $Id: loncfile.pm,v 1.114 2011/11/14 00:20:31 raeburn 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
@@ -88,10 +66,14 @@ 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.
@@ -120,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
@@ -170,122 +156,83 @@ 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{^https?\://[^/]+}{};
+ $Url=~ s{//+}{/}g;
+ $Url=~ s{^/}{};
+ $Url=$Apache::lonnet::perlvar{'lonDocRoot'}."/$Url";
+ &Debug($r, "Returning $Url \n");
+ return $Url;
}
-=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;
+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;
}
-=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;
-
+sub display {
+ my $fn=shift;
+ my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
+ $fn=~s/^\Q$londocroot\E//;
+ $fn=~s{/\./}{/}g;
+ return ''.$fn.'';
}
-=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 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) {
+ if (&Apache::lonnet::metadata($published,'obsolete')) {
+ return 1;
+ }
+ return 0;
+ } else {
+ return 1;
+ }
+}
+# 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.
@@ -294,15 +241,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
@@ -310,6 +258,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.
@@ -319,26 +270,39 @@ Returns:
=cut
sub exists {
- my ($user, $domain, $dir, $file) = @_;
-
- # Create complete paths in publication and construction space.
+ my ($user, $domain, $construct, $creating) = @_;
+ $creating ||= 'file';
- my $published = &PublicationPath($domain, $user, $dir, $file);
- my $construct = &ConstructionPath($user, $dir, $file);
-
- # If the resource exists in either space indicate this fact.
- # Note that the check for existence in resource space is stricter.
+ 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.').'
');
+
+ }
- my $result;
- if ( -e $published) {
- $result.='
Warning: target file exists, and has been published!
';
+ }
+ return ($type,$result);
}
=pod
@@ -377,12 +341,81 @@ 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))
+ .'
');
+ my ($request, $user, $fn) = @_;
+ $request->print(&done(&url($fn)));
}
=pod
@@ -479,34 +507,84 @@ new filename relative to the current dir
=cut
sub Rename1 {
- my ($request, $filename, $user, $domain, $dir) = @_;
- &Debug($request, "Username - ".$user." filename: ".$filename."\n");
- my $conspace = $filename;
-
- my $cancelurl = "/priv/".$filename;
- $cancelurl =~ s/\/home\///;
- $cancelurl =~ s/\/public_html//;
-
- if(-e $conspace) {
- if($ENV{'form.newfilename'}) {
- my $newfilename = $ENV{'form.newfilename'};
- $request->print(&checksuffix($filename, $newfilename));
- $request->print(&exists($user, $domain, $dir, $newfilename));
- $request->print('
Rename '.$filename.' to '.
- $dir.'/'.$newfilename.'?
');
- &CloseForm1($request, $cancelurl);
+ my ($request, $user, $domain, $fn, $newfilename, $style) = @_;
+
+ if(-e $fn) {
+ if($newfilename) {
+ # is dest a dir
+ if ($style eq 'move') {
+ if (-d $newfilename) {
+ if ($fn =~ m|/([^/]*)$|) { $newfilename .= '/'.$1; }
+ }
+ }
+ if ($newfilename =~ m|/[^\.]+$|) {
+ #no extension add on original extension
+ if ($fn =~ m|/[^\.]*\.([^\.]+)$|) {
+ $newfilename.='.'.$1;
+ }
+ }
+ $request->print(&checksuffix($fn, $newfilename));
+ #renaming a dir, delete the trailing /
+ #remove second to last element for current dir
+ if (-d $fn) {
+ $newfilename=~/\.(\w+)$/;
+ if (&Apache::loncommon::fileembstyle($1) eq 'ssi') {
+ $request->print('
'.
+ &mt('Cannot change MIME type of a directory.').
+ ''.
+ ' '.&mt('Cancel').'
'
+ .&mt('No such file: [_1]',
+ &display($fn))
+ .'
'
+ );
return;
}
}
+
=pod
=item Delete1
@@ -518,35 +596,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('
'
+ .&mt('No such file: [_1]',
+ &display($fn))
+ .'
'
+ );
+ }
}
=pod
@@ -617,7 +738,9 @@ Parameters:
=item $username - Name of the user that is requesting the directory creation.
-=item $path - current directory relative to construction space.
+=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.
@@ -637,27 +760,159 @@ causes the newdir operation to transitio
=cut
-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('
'
+ .&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|;
+ }
+ $newfilename.=".$extension";
+ }
+ }
+ my ($type, $result)=&exists($user,$domain,$newfilename);
+ $request->print($result);
+ if ($type eq 'error') {
+ $request->print('');
+ } else {
+ my $extension;
+
+ 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
@@ -689,40 +944,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 = &Apache::lonnet::escape(&File::Basename::basename($dest));
- my $dpath= &File::Basename::dirname($dest);
- $dest = $dpath.'/'.$base;
-
-
- &Debug($r, "Final url after rewrite: $dest");
-
- $r->print('