--- loncom/publisher/lonpublisher.pm 2003/12/29 19:13:23 1.157
+++ loncom/publisher/lonpublisher.pm 2008/05/12 20:59:22 1.233
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Publication Handler
#
-# $Id: lonpublisher.pm,v 1.157 2003/12/29 19:13:23 www Exp $
+# $Id: lonpublisher.pm,v 1.233 2008/05/12 20:59:22 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -121,13 +121,16 @@ use HTML::LCParser;
use Apache::lonxml;
use Apache::loncacc;
use DBI;
-use Apache::lonnet();
+use Apache::lonnet;
use Apache::loncommon();
use Apache::lonmysql;
use Apache::lonlocal;
use Apache::loncfile;
-use Apache::lonmeta;
+use LONCAPA::lonmetadata;
+use Apache::lonmsg;
use vars qw(%metadatafields %metadatakeys);
+use LONCAPA qw(:DEFAULT :match);
+
my %addid;
my %nokey;
@@ -137,6 +140,11 @@ my $docroot;
my $cuname;
my $cudom;
+my $registered_cleanup;
+my $modified_urls;
+
+my $lock;
+
=pod
=item B $title:".
" $title:".
+ " $title:".
' '.&mt('New parameters or stored values').
+ $scrout.=' '.&mt('New parameters or saved values').
': '.$chparms.' '.&mt('Obsolete parameters or stored values').': '.
- $chparms.' '.
- &mt('If this resource is in active use, student performance data from the previous version may become inaccessible.').' '.&mt('Obsolete parameters or saved values').': '.
+ $chparms.' '.
+ &mt('If this resource is in active use, student performance data from the previous version may become inaccessible.').'
".
'';
}
+sub text_with_browse_field {
+ my ($title,$name,$value,$restriction)=@_;
+ $value=~s/^\s+//gs;
+ $value=~s/\s+$//gs;
+ $value=~s/\s+/ /gs;
+ $title=&mt($title);
+ $env{'form.'.$name}=$value;
+ return "\n
".
+ ''.
+ ''.&mt('Select').' '.
+ ''.&mt('Search').'';
+
+}
+
sub hiddenfield {
my ($name,$value)=@_;
+ $env{'form.'.$name}=$value;
return "\n".'';
}
+sub checkbox {
+ my ($name,$text)=@_;
+ return "\n
";
+}
+
sub selectbox {
my ($title,$name,$value,$functionref,@idlist)=@_;
$title=&mt($title);
$value=(split(/\s*,\s*/,$value))[-1];
+ if (defined($value)) {
+ $env{'form.'.$name}=$value;
+ } else {
+ $env{'form.'.$name}=$idlist[0];
+ }
my $selout="\n
';
}
+sub select_level_form {
+ my ($value,$name)=@_;
+ $env{'form.'.$name}=$value;
+ if (!defined($value)) { $env{'form.'.$name}=0; }
+ return &Apache::loncommon::select_level_form($value,$name);
+}
#########################################
#########################################
@@ -364,15 +411,14 @@ sub urlfixup {
if ($url =~ /^mailto:/i) { return $url; }
#internal document links need no fixing
if ($url =~ /^\#/) { return $url; }
- my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/);
- foreach (values %Apache::lonnet::hostname) {
- if ($_ eq $host) {
- $url=~s/^http\:\/\///;
- $url=~s/^$host//;
- }
+ my ($host)=($url=~m{(?:(?:http|https|ftp)://)*([^/]+)});
+ my @lonids = &Apache::lonnet::machine_ids($host);
+ if (@lonids) {
+ $url=~s{^(?:http|https|ftp)://}{};
+ $url=~s/^\Q$host\E//;
}
- if ($url=~/^http\:\/\//) { return $url; }
- $url=~s/\~$cuname/res\/$cudom\/$cuname/;
+ if ($url=~m{^(?:http|https|ftp)://}) { return $url; }
+ $url=~s{\Q~$cuname\E}{res/$cudom/$cuname};
return $url;
}
@@ -423,11 +469,11 @@ sub set_allow {
}
if (($newurl !~ /^javascript:/i) &&
($newurl !~ /^mailto:/i) &&
- ($newurl !~ /^http:/i) &&
+ ($newurl !~ /^(?:http|https|ftp):/i) &&
($newurl !~ /^\#/)) {
$$allow{&absoluteurl($newurl,$target)}=1;
}
- return $return_url
+ return $return_url;
}
#########################################
@@ -450,10 +496,15 @@ sub get_subscribed_hosts {
$target=~/(.*)\/([^\/]+)$/;
my $srcf=$2;
opendir(DIR,$1);
+ # cycle through listed files, subscriptions used to exist
+ # as "filename.lonid"
while ($filename=readdir(DIR)) {
- if ($filename=~/\Q$srcf\E\.(\w+)$/) {
+ if ($filename=~/\Q$srcf\E\.($match_lonid)$/) {
my $subhost=$1;
- if (($subhost ne 'meta' && $subhost ne 'subscription') &&
+ if (($subhost ne 'meta'
+ && $subhost ne 'subscription'
+ && $subhost ne 'meta.subscription'
+ && $subhost ne 'tmp') &&
($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) {
push(@subscribed,$subhost);
}
@@ -462,19 +513,13 @@ sub get_subscribed_hosts {
closedir(DIR);
my $sh;
if ( $sh=Apache::File->new("$target.subscription") ) {
- &Apache::lonnet::logthis("opened $target.subscription");
while (my $subline=<$sh>) {
- &Apache::lonnet::logthis("Trying $subline");
- if ($subline =~ /(^\w+):/) {
+ if ($subline =~ /^($match_lonid):/) {
if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) {
push(@subscribed,$1);
}
- } else {
- &Apache::lonnet::logthis("No Match for $subline");
}
}
- } else {
- &Apache::lonnet::logthis("Unable to open $target.subscription");
}
return @subscribed;
}
@@ -504,13 +549,15 @@ sub get_max_ids_indices {
my %duplicatedids;
my $parser=HTML::LCParser->new($content);
+ $parser->xml_mode(1);
my $token;
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
my $counter;
if ($counter=$addid{$token->[1]}) {
if ($counter eq 'id') {
- if (defined($token->[2]->{'id'})) {
+ if (defined($token->[2]->{'id'}) &&
+ $token->[2]->{'id'} !~ /^\s*$/) {
$maxid=($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid;
if (exists($allids{$token->[2]->{'id'}})) {
$duplicateids=1;
@@ -522,7 +569,8 @@ sub get_max_ids_indices {
$needsfixup=1;
}
} else {
- if (defined($token->[2]->{'index'})) {
+ if (defined($token->[2]->{'index'}) &&
+ $token->[2]->{'index'} !~ /^\s*$/) {
$maxindex=($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex;
} else {
$needsfixup=1;
@@ -564,11 +612,11 @@ sub get_all_text_unbalanced {
} elsif ($token->[0] eq 'E') {
$result.=$token->[2];
}
- if ($result =~ /(.*)\Q$tag\E(.*)/s) {
+ if ($result =~ /\Q$tag\E/s) {
+ ($result,my $redo)=$result =~ /(.*)\Q$tag\E(.*)/is;
#&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2);
#&Apache::lonnet::logthis('Result is :'.$1);
- $result=$1;
- my $redo=$tag.$2;
+ $redo=$tag.$redo;
push (@$pars,HTML::LCParser->new(\$redo));
$$pars[-1]->xml_mode('1');
last;
@@ -608,7 +656,7 @@ sub fix_ids_and_indices {
join(', ',@duplicatedids));
if ($duplicateids) {
print $logfile "Duplicate ID(s) exist, ".join(', ',@duplicatedids)."\n";
- my $outstring=''.&mt('Unable to publish file, it contains duplicated ID(s), ID(s) need to be unique. The duplicated ID(s) are').': '.join(', ',@duplicatedids).'';
+ my $outstring=''.&mt('Unable to publish file, it contains duplicated ID(s), ID(s) need to be unique. The duplicated ID(s) are').': '.join(', ',@duplicatedids).'';
return ($outstring,1);
}
if ($needsfixup) {
@@ -631,30 +679,37 @@ sub fix_ids_and_indices {
$allow{$token->[2]->{'src'}}=1;
next;
}
+ if ($lctag eq 'base') { next; }
my %parms=%{$token->[2]};
$counter=$addid{$tag};
if (!$counter) { $counter=$addid{$lctag}; }
if ($counter) {
if ($counter eq 'id') {
- unless (defined($parms{'id'})) {
+ unless (defined($parms{'id'}) &&
+ $parms{'id'}!~/^\s*$/) {
$maxid++;
$parms{'id'}=$maxid;
- print $logfile 'ID: '.$tag.':'.$maxid."\n";
+ print $logfile 'ID(new) : '.$tag.':'.$maxid."\n";
+ } else {
+ print $logfile 'ID(kept): '.$tag.':'.$parms{'id'}."\n";
}
} elsif ($counter eq 'index') {
- unless (defined($parms{'index'})) {
+ unless (defined($parms{'index'}) &&
+ $parms{'index'}!~/^\s*$/) {
$maxindex++;
$parms{'index'}=$maxindex;
print $logfile 'Index: '.$tag.':'.$maxindex."\n";
}
}
}
- foreach my $type ('src','href','background','bgimg') {
- foreach my $key (keys(%parms)) {
- if ($key =~ /^$type$/i) {
- $parms{$key}=&set_allow(\%allow,$logfile,
- $target,$tag,
- $parms{$key});
+ unless ($parms{'type'} eq 'zombie') {
+ foreach my $type ('src','href','background','bgimg') {
+ foreach my $key (keys(%parms)) {
+ if ($key =~ /^$type$/i) {
+ $parms{$key}=&set_allow(\%allow,$logfile,
+ $target,$tag,
+ $parms{$key});
+ }
}
}
}
@@ -665,6 +720,7 @@ sub fix_ids_and_indices {
($lctag eq 'image')) {
my $next_token=$parser[-1]->get_token();
if ($next_token->[0] eq 'T') {
+ $next_token->[1] =~ s/[\n\r\f]+//g;
$next_token->[1]=&set_allow(\%allow,$logfile,
$target,$tag,
$next_token->[1]);
@@ -771,67 +827,69 @@ sub store_metadata {
# Determine if the table exists
my $status = &Apache::lonmysql::check_table('metadata');
if (! defined($status)) {
- $error='WARNING: Cannot connect to '.
- 'database!';
+ $error='WARNING: Cannot connect to '.
+ 'database!';
&Apache::lonnet::logthis($error);
return ($error,undef);
}
if ($status == 0) {
# It would be nice to actually create the table....
- $error ='WARNING: The metadata table does not '.
- 'exist in the LON-CAPA database.';
+ $error ='WARNING: The metadata table does not '.
+ 'exist in the LON-CAPA database.';
&Apache::lonnet::logthis($error);
return ($error,undef);
}
+ my $dbh = &Apache::lonmysql::get_dbh();
if (($metadata{'obsolete'}) || ($metadata{'copyright'} eq 'priv') ||
($metadata{'copyright'} eq 'custom')) {
-# remove this entry
- $status=&Apache::lonmysql::remove_from_table
- ('metadata','url',$metadata{'url'});
+ # remove this entry
+ my $delitem = 'url = '.$dbh->quote($metadata{'url'});
+ $status = &LONCAPA::lonmetadata::delete_metadata($dbh,undef,$delitem);
+
} else {
-# store new data
-# adjust some values to metadatadatabase (e.g., "usage" is a reserved word)
- $metadata{'creationdate'}=
- &Apache::lonmysql::sqltime($metadata{'creationdate'});
- $metadata{'lastrevisiondate'}=
- &Apache::lonmysql::sqltime($metadata{'lastrevisiondate'});
- $metadata{'sequsage'}=$metadata{'usage'};
- $metadata{'sequsage_list'}=$metadata{'usage_list'};
- my %newmetadata=();
-# see if we have old entries
- my @oldmeta=&Apache::lonmysql::get_rows('metadata',
- "url LIKE BINARY '".
- $metadata{'url'}."'");
- if ($#oldmeta==0) {
-# yes, there is one old entry, transfer to newmetadata
- %newmetadata=&Apache::lonmeta::metadata_col_to_hash(@{$oldmeta[0]});
-# remove old entry
- $status=&Apache::lonmysql::remove_from_table
- ('metadata','url',$metadata{'url'});
- } elsif ($#oldmeta>0) {
-# more than one entry fit - how did that happen?
- $error='Error occured retrieving old values in '.
- 'metadata table in LON-CAPA database: '.$#oldmeta.
- ' matches';
- &Apache::lonnet::logthis($error);
- return ($error,undef);
- }
-# store new data on top of it
- foreach (keys %metadata) {
- $newmetadata{$_}=$metadata{$_};
- }
- $status = &Apache::lonmysql::store_row('metadata',\%newmetadata);
+ $status = &LONCAPA::lonmetadata::update_metadata($dbh,undef,undef,
+ \%metadata);
}
- if (! defined($status)) {
- $error='Error occured storing new values in '.
- 'metadata table in LON-CAPA database';
+ if (defined($status) && $status ne '') {
+ $error='Error occured saving new values in '.
+ 'metadata table in LON-CAPA database';
&Apache::lonnet::logthis($error);
+ &Apache::lonnet::logthis($status);
return ($error,undef);
}
- return (undef,$status);
+ return (undef,'success');
}
+# ========================================== Parse file for errors and warnings
+
+sub checkonthis {
+ my ($r,$source)=@_;
+ my $uri=&Apache::lonnet::hreflocation($source);
+ $uri=~s/\/$//;
+ my $result=&Apache::lonnet::ssi_body($uri,
+ ('grade_target'=>'web',
+ 'return_only_error_and_warning_counts' => 1));
+ my ($errorcount,$warningcount)=split(':',$result);
+ if (($errorcount) || ($warningcount)) {
+ $r->print('
'.$uri.': ');
+ if ($errorcount) {
+ $r->print(''.
+ $errorcount.' '.
+ &mt('error(s)').' ');
+ }
+ if ($warningcount) {
+ $r->print(''.
+ $warningcount.' '.
+ &mt('warning(s)').'');
+ }
+ } else {
+ #$r->print(''.&mt('ok').'');
+ }
+ $r->rflush();
+ return ($warningcount,$errorcount);
+}
+
# ============================================== Parse file itself for metadata
#
# parses a file with target meta, sets global %metadatafields %metadatakeys
@@ -882,10 +940,10 @@ sub publish {
my %allow=();
unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
- return (''.&mt('No write permission to user directory, FAIL').'',1);
+ return (''.&mt('No write permission to user directory, FAIL').'',1);
}
print $logfile
-"\n\n================= Publish ".localtime()." Phase One ================\n".$ENV{'user.name'}.'@'.$ENV{'user.domain'}."\n";
+"\n\n================= Publish ".localtime()." Phase One ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n";
if (($style eq 'ssi') || ($style eq 'rat') || ($style eq 'prv')) {
# ------------------------------------------------------- This needs processing
@@ -896,7 +954,7 @@ sub publish {
print $logfile "Copied original file to ".$copyfile."\n";
} else {
print $logfile "Unable to write backup ".$copyfile.':'.$!."\n";
- return ("Failed to write backup copy, $!,FAIL",1);
+ return ("Failed to write backup copy, $!,FAIL",1);
}
# ------------------------------------------------------------- IDs and indices
@@ -908,29 +966,34 @@ sub publish {
$scrout.=''.&mt('Dependencies').'
';
my $allowstr='';
- foreach (sort(keys(%allow))) {
- my $thisdep=$_;
+ foreach my $thisdep (sort(keys(%allow))) {
if ($thisdep !~ /[^\s]/) { next; }
+ if ($thisdep =~/\$/) {
+ $scrout.='
'
+ .&mt('The resource depends on another resource with variable filename, i.e., [_1].',''.$thisdep.'').'
'
+ .&mt('You likely need to explicitly allow access to all possible dependencies using the [_1]-tag.','<allow>')
+ .'
';
+ }
unless ($style eq 'rat') {
$allowstr.="\n".'
';
- unless ($thisdep=~/\*/) {
+ if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) {
$scrout.='';
}
$scrout.=''.$thisdep.'';
- unless ($thisdep=~/\*/) {
+ if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) {
$scrout.='';
if (
&Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
$thisdep.'.meta') eq '-1') {
- $scrout.= ' - '.&mt('Currently not available').
- '';
+ $scrout.= ' - '.&mt('Currently not available').
+ '';
} else {
my %temphash=(&Apache::lonnet::declutter($target).'___'.
&Apache::lonnet::declutter($thisdep).'___usage'
=> time);
- $thisdep=~/^\/res\/(\w+)\/(\w+)\//;
+ $thisdep=~m{^/res/($match_domain)/($match_username)/};
if ((defined($1)) && (defined($2))) {
&Apache::lonnet::put('nohist_resevaldata',\%temphash,
$1,$2);
@@ -938,22 +1001,17 @@ sub publish {
}
}
}
- $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$allowstr\n$1\n/s;
+ $outstring=~s/\n*(\<\/[^\>]+\>[^<]*)$/$allowstr\n$1\n/s;
-### FIXME: is this really what we want?
-# I dont' think so, to will corrupt any UTF-8 resources at least,
-# and any encoding other than ISO-8859-1 will probably break
- #Encode any High ASCII characters
- #$outstring=&HTML::Entities::encode($outstring,"\200-\377");
# ------------------------------------------------------------- Write modified.
{
my $org;
unless ($org=Apache::File->new('>'.$source)) {
print $logfile "No write permit to $source\n";
- return (''.&mt('No write permission to').
+ return (''.&mt('No write permission to').
' '.$source.
- ', '.&mt('FAIL').'',1);
+ ', '.&mt('FAIL').'',1);
}
print($org $outstring);
}
@@ -977,14 +1035,14 @@ sub publish {
}
# ------------------------------------------------ First, check out environment
- unless (-e $source.'.meta') {
- $metadatafields{'author'}=$ENV{'environment.firstname'}.' '.
- $ENV{'environment.middlename'}.' '.
- $ENV{'environment.lastname'}.' '.
- $ENV{'environment.generation'};
+ if ((!(-e $source.'.meta')) || ($env{'form.forceoverride'})) {
+ $metadatafields{'author'}=$env{'environment.firstname'}.' '.
+ $env{'environment.middlename'}.' '.
+ $env{'environment.lastname'}.' '.
+ $env{'environment.generation'};
$metadatafields{'author'}=~s/\s+/ /g;
$metadatafields{'author'}=~s/\s+$//;
- $metadatafields{'owner'}=$cuname.'@'.$cudom;
+ $metadatafields{'owner'}=$cuname.':'.$cudom;
# ------------------------------------------------ Check out directory hierachy
@@ -1002,6 +1060,7 @@ sub publish {
$scrout.=&metaread($logfile,$currentpath.'default.meta',$prefix);
$prefix=~s|^\.\./||;
}
+
# ----------------------------------------------------------- Parse file itself
# read %metadatafields from file itself
@@ -1026,9 +1085,18 @@ sub publish {
delete $metadatafields{$_};
}
}
+# ------------------------------------------------------------- Save some stuff
+ my %savemeta=();
+ foreach ('title') {
+ $savemeta{$_}=$metadatafields{$_};
+ }
# ------------------------------------------ See if anything new in file itself
$allmeta=&parseformeta($source,$style);
+# ----------------------------------------------------------- Restore the stuff
+ foreach (keys %savemeta) {
+ $metadatafields{$_}=$savemeta{$_};
+ }
}
@@ -1039,14 +1107,16 @@ sub publish {
if (($_=~/^parameter/) || ($_=~/^stores/)) {
unless ($_=~/\.\w+$/) {
unless ($oldparmstores{$_}) {
- print $logfile 'New: '.$_."\n";
- $chparms.=$_.' ';
+ my $disp_key = $_;
+ $disp_key =~ tr/\0/_/;
+ print $logfile ('New: '.$disp_key."\n");
+ $chparms .= $disp_key.' ';
}
}
}
}
if ($chparms) {
- $scrout.=''.&mt('Warning!').
- '
';
+ $scrout.=''.&mt('Warning!').
+ '
';
+ }
+ if ($metadatafields{'copyright'} eq 'priv') {
+ $scrout.='
'. + &mt('Copyright/distribution option "Private" is no longer supported. Select another option from below. Consider "Custom Rights" for maximum control over the usage of your resource.').'