--- loncom/publisher/loncfile.pm 2003/08/04 20:08:23 1.38
+++ loncom/publisher/loncfile.pm 2011/10/30 19:27:27 1.112
@@ -9,7 +9,7 @@
# and displays a page showing the results of the action.
#
#
-# $Id: loncfile.pm,v 1.38 2003/08/04 20:08:23 www Exp $
+# $Id: loncfile.pm,v 1.112 2011/10/30 19:27:27 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -69,9 +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.
@@ -100,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 true.
-
- 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
@@ -150,101 +156,81 @@ Global References
=cut
sub URLToPath {
- my $Url = shift;
- &Debug($r, "UrlToPath got: $Url");
- $Url=~ s/\/+/\//g;
- $Url=~ s/^http\:\/\/[^\/]+//;
- $Url=~ s/^\///;
- $Url=~ s/(\~|priv\/)(\w+)\//\/home\/$2\/public_html\//;
- &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\/(\w+)\/public\_html/\/priv\/$1/;
+ $fn=~s/^\/home\/httpd\/html//;
+ $fn=~s/\/\.\//\//g;
+ $fn=&HTML::Entities::encode($fn,'<>"&');
return $fn;
}
sub display {
my $fn=shift;
- $fn=~s/^\/home\/(\w+)\/public\_html//;
- return ''.$fn.'';
+ $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;
+# 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;
+ }
}
-=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 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.
@@ -253,15 +239,16 @@ sub ConstructionPath {
=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
@@ -269,6 +256,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.
@@ -278,29 +268,39 @@ Returns:
=cut
sub exists {
- my ($user, $domain, $dir, $file) = @_;
+ 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.').'
');
+
+ }
- # 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!
';
+ }
+ return ($type,$result);
}
=pod
@@ -339,28 +339,63 @@ 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)=@_;
+ my ($request,$dest,$subdir,$fn,$uname,$udom)=@_;
#remove bad characters
- if ($dest=~/[\#\?&]/) {
- $request->print("
Invalid characters in requested name have been removed.
");
- $dest=~s/[\#\?&]//g;
+ 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
@@ -464,10 +504,16 @@ new filename relative to the current dir
=cut
sub Rename1 {
- my ($request, $user, $domain, $fn, $newfilename) = @_;
+ 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|/[^\.]*\.([^\.]+)$|) {
@@ -476,33 +522,66 @@ sub Rename1 {
}
$request->print(&checksuffix($fn, $newfilename));
#renaming a dir, delete the trailing /
- #remove last element for current dir
- my $dir=$fn;
- if ($fn =~ m|/$|) {
- $fn =~ s|/$||;
- $dir =~ s|/[^/]*$||;
+ #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('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).'?