--- loncom/publisher/lonpublisher.pm 2004/01/27 22:54:59 1.163 +++ loncom/publisher/lonpublisher.pm 2013/01/15 18:21:31 1.281 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Publication Handler # -# $Id: lonpublisher.pm,v 1.163 2004/01/27 22:54:59 albertel Exp $ +# $Id: lonpublisher.pm,v 1.281 2013/01/15 18:21:31 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -66,10 +66,10 @@ invocation by F: =head1 OVERVIEW -Authors can only write-access the C space. They can -copy resources into the resource area through the publication step, -and move them back through a recover step. Authors do not have direct -write-access to their resource space. +Authors can only write-access the C space. +They can copy resources into the resource area through the +publication step, and move them back through a recover step. +Authors do not have direct write-access to their resource space. During the publication step, several events will be triggered. Metadata is gathered, where a wizard manages default @@ -118,17 +118,21 @@ use Apache::File; use File::Copy; use Apache::Constants qw(:common :http :methods); use HTML::LCParser; +use HTML::Entities; +use Encode::Encoder; use Apache::lonxml; -use Apache::loncacc; use DBI; -use Apache::lonnet(); +use Apache::lonnet; use Apache::loncommon(); +use Apache::lonhtmlcommon; 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; @@ -138,6 +142,11 @@ my $docroot; my $cuname; my $cudom; +my $registered_cleanup; +my $modified_urls; + +my $lock; + =pod =item B @@ -178,17 +187,18 @@ sub metaeval { if ($token->[0] eq 'S') { my $entry=$token->[1]; my $unikey=$entry; + next if ($entry =~ m/^(?:parameter|stores)_/); if (defined($token->[2]->{'package'})) { - $unikey.='_package_'.$token->[2]->{'package'}; + $unikey.="\0package\0".$token->[2]->{'package'}; } if (defined($token->[2]->{'part'})) { - $unikey.='_'.$token->[2]->{'part'}; + $unikey.="\0".$token->[2]->{'part'}; } if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; + $unikey.="\0".$token->[2]->{'id'}; } if (defined($token->[2]->{'name'})) { - $unikey.='_'.$token->[2]->{'name'}; + $unikey.="\0".$token->[2]->{'name'}; } foreach (@{$token->[3]}) { $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; @@ -199,7 +209,8 @@ sub metaeval { } } my $newentry=$parser->get_text('/'.$entry); - if ($entry eq 'customdistributionfile') { + if (($entry eq 'customdistributionfile') || + ($entry eq 'sourcerights')) { $newentry=~s/^\s*//; if ($newentry !~m|^/res|) { $newentry=$prefix.$newentry; } } @@ -254,8 +265,9 @@ sub metaread { my ($logfile,$fn,$prefix)=@_; unless (-e $fn) { print($logfile 'No file '.$fn."\n"); - return '
'.&mt('No file').': '. - &Apache::loncfile::display($fn).''; + return '

' + .&mt('No file: [_1]',&Apache::loncfile::display($fn)) + .'

'; } print($logfile 'Processing '.$fn."\n"); my $metastring; @@ -264,8 +276,9 @@ sub metaread { $metastring=join('',<$metafh>); } &metaeval($metastring,$prefix); - return '
'.&mt('Processed file').': '. - &Apache::loncfile::display($fn).''; + return '

' + .&mt('Processed file: [_1]',&Apache::loncfile::display($fn)) + .'

'; } ######################################### @@ -274,9 +287,8 @@ sub metaread { sub coursedependencies { my $url=&Apache::lonnet::declutter(shift); $url=~s/\.meta$//; - my ($adomain,$aauthor)=($url=~/^(\w+)\/(\w+)\//); - my $regexp=$url; - $regexp=~s/(\W)/\\$1/g; + my ($adomain,$aauthor)=($url=~ m{^($match_domain)/($match_username)/}); + my $regexp=quotemeta($url); $regexp='___'.$regexp.'___course'; my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain, $aauthor,$regexp); @@ -317,37 +329,76 @@ string which presents the form field (fo ######################################### ######################################### sub textfield { - my ($title,$name,$value)=@_; + my ($title,$name,$value,$noline)=@_; $value=~s/^\s+//gs; $value=~s/\s+$//gs; $value=~s/\s+/ /gs; $title=&mt($title); - return "\n

$title:". - "


". - ''; + $env{'form.'.$name}=$value; + return "\n".&Apache::lonhtmlcommon::row_title($title) + .'' + .&Apache::lonhtmlcommon::row_closure($noline); +} + +sub text_with_browse_field { + my ($title,$name,$value,$restriction,$noline)=@_; + $value=~s/^\s+//gs; + $value=~s/\s+$//gs; + $value=~s/\s+/ /gs; + $title=&mt($title); + $env{'form.'.$name}=$value; + return "\n".&Apache::lonhtmlcommon::row_title($title) + .'' + .'
' + .'' + .&mt('Select') + .' ' + .'' + .&mt('Search') + .'' + .&Apache::lonhtmlcommon::row_closure($noline); } 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]; - my $selout="\n

$title:". - '


'; foreach (@idlist) { - $selout.='';} + $selout.=' selected="selected"'; + } + $selout.='>'.&{$functionref}($_).''; } - return $selout.''; + $selout.=''.&Apache::lonhtmlcommon::row_closure(); + return $selout; } +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); +} ######################################### ######################################### @@ -369,15 +420,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; } @@ -428,11 +478,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; } ######################################### @@ -455,10 +505,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); } @@ -467,19 +522,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; } @@ -509,13 +558,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; @@ -527,7 +578,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; @@ -569,11 +621,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; @@ -613,7 +665,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) { @@ -622,6 +674,7 @@ sub fix_ids_and_indices { "Max Index: $maxindex (min 10)\n"; } my $outstring=''; + my $responsecounter=1; my @parser; $parser[0]=HTML::LCParser->new(\$content); $parser[-1]->xml_mode(1); @@ -636,30 +689,42 @@ sub fix_ids_and_indices { $allow{$token->[2]->{'src'}}=1; next; } + if ($lctag eq 'base') { next; } + if (($lctag eq 'part') || ($lctag eq 'problem')) { + $responsecounter=0; + } + if ($lctag=~/response$/) { $responsecounter++; } + if ($lctag eq 'import') { $responsecounter++; } 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}); + } } } } @@ -670,6 +735,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]); @@ -724,7 +790,7 @@ sub fix_ids_and_indices { } if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } $outstring.='<'.$tag.$newparmstring.$endtag.'>'; - if ($lctag eq 'm' || $lctag eq 'script' + if ($lctag eq 'm' || $lctag eq 'script' || $lctag eq 'answer' || $lctag eq 'display' || $lctag eq 'tex') { $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser); } @@ -733,7 +799,12 @@ sub fix_ids_and_indices { unless ($token->[1] eq 'allow') { $outstring.='[1].'>'; } - } + } + if ((($token->[1] eq 'part') || ($token->[1] eq 'problem')) + && (!$responsecounter)) { + my $outstring=''.&mt('Found [_1] without responses. This resource cannot be published.',$token->[1]).''; + return ($outstring,1); + } } else { $outstring.=$token->[1]; } @@ -776,67 +847,75 @@ 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='' + .&mt('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 ='' + .&mt('WARNING: The metadata table does not exist in the LON-CAPA database!') + .''; &Apache::lonnet::logthis($error); return ($error,undef); } - if (($metadata{'obsolete'}) || ($metadata{'copyright'} eq 'priv') || - ($metadata{'copyright'} eq 'custom')) { -# remove this entry - $status=&Apache::lonmysql::remove_from_table - ('metadata','url',$metadata{'url'}); + my $dbh = &Apache::lonmysql::get_dbh(); + if (($metadata{'obsolete'}) || ($metadata{'copyright'} eq 'priv')) { + # 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='' + .&mt('Error occurred 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('

'.&mt('Warnings and Errors').'

'); + $r->print(''.$uri.':'); + $r->print(''); + } 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 @@ -868,7 +947,7 @@ backup copies, performs any automatic pr especially for rat and ssi files), Returns a 2 element array, the first is the string to be shown to the -user, the second is an error code, either 1 (an error occured) or 0 +user, the second is an error code, either 1 (an error occurred) or 0 (no error occurred) I @@ -887,10 +966,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 @@ -901,7 +980,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 ("".&mt("Failed to write backup copy, [_1], FAIL",$1)."",1); } # ------------------------------------------------------------- IDs and indices @@ -911,54 +990,65 @@ sub publish { if ($error) { return ($outstring,$error); } # ------------------------------------------------------------ Construct Allows - $scrout.='

'.&mt('Dependencies').'

'; + my $outdep=''; # Collect dependencies output data my $allowstr=''; - foreach (sort(keys(%allow))) { - my $thisdep=$_; + foreach my $thisdep (sort(keys(%allow))) { if ($thisdep !~ /[^\s]/) { next; } + if ($thisdep =~/\$/) { + $outdep.='
' + .&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>') + ."
\n"; + } unless ($style eq 'rat') { $allowstr.="\n".''; } - $scrout.='
'; - unless ($thisdep=~/\*/) { - $scrout.=''; + $outdep.='
'; + if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) { + $outdep.=''; } - $scrout.=''.$thisdep.''; - unless ($thisdep=~/\*/) { - $scrout.=''; + $outdep.=''.$thisdep.''; + if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) { + $outdep.=''; if ( &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. $thisdep.'.meta') eq '-1') { - $scrout.= ' - '.&mt('Currently not available'). - ''; + $outdep.= ' - '.&mt('Currently not available'). + ''; } else { +# +# Store the fact that the dependency has been used by the target file +# Unfortunately, usage is erroneously named sequsage in lonmeta.pm +# The translation happens in lonmetadata.pm +# 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); } } } + $outdep.='

'; } - $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$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"); + if ($outdep) { + $scrout.='

'.&mt('Dependencies').'

' + .$outdep + } + $outstring=~s/\n*(\<\/[^\>]+\>[^<]*)$/$allowstr\n$1\n/s; + # ------------------------------------------------------------- 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); } @@ -976,37 +1066,38 @@ sub publish { my %oldparmstores=(); unless ($batch) { - $scrout.='

'.&mt('Metadata Information').' ' . - Apache::loncommon::help_open_topic("Metadata_Description") + $scrout.='

'.&mt('Metadata').' ' . + &Apache::loncommon::help_open_topic("Metadata_Description") . '

'; } # ------------------------------------------------ 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 my $thisdisfn=$source; - $thisdisfn=~s/^\/home\/\Q$cuname\E\///; - my @urlparts=split(/\//,$thisdisfn); + $thisdisfn=~s/^\Q$docroot\E\/priv\/\Q$cudom\E\/\Q$cuname\E\///; + my @urlparts=('.',split(/\//,$thisdisfn)); $#urlparts--; - my $currentpath='/home/'.$cuname.'/'; + my $currentpath=$docroot.'/priv/'.$cudom.'/'.$cuname.'/'; my $prefix='../'x($#urlparts); - foreach (@urlparts) { - $currentpath.=$_.'/'; + foreach my $subdir (@urlparts) { + $currentpath.=$subdir.'/'; $scrout.=&metaread($logfile,$currentpath.'default.meta',$prefix); $prefix=~s|^\.\./||; } + # ----------------------------------------------------------- Parse file itself # read %metadatafields from file itself @@ -1031,10 +1122,18 @@ sub publish { delete $metadatafields{$_}; } } +# ------------------------------------------------------------- Save some stuff + my %savemeta=(); + foreach ('title') { + if ($metadatafields{$_}) { $savemeta{$_}=$metadatafields{$_}; } + } # ------------------------------------------ See if anything new in file itself $allmeta=&parseformeta($source,$style); - +# ----------------------------------------------------------- Restore the stuff + foreach (keys %savemeta) { + $metadatafields{$_}=$savemeta{$_}; + } } @@ -1045,14 +1144,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('New parameters or stored values'). + $scrout.='

'.&mt('New parameters or saved values'). ': '.$chparms.'

'; } @@ -1061,16 +1162,24 @@ sub publish { if (($_=~/^parameter/) || ($_=~/^stores/)) { unless (($metadatafields{$_.'.name'}) || ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { - print $logfile 'Obsolete: '.$_."\n"; - $chparms.=$_.' '; + my $disp_key = $_; + $disp_key =~ tr/\0/_/; + print $logfile ('Obsolete: '.$disp_key."\n"); + $chparms.=$disp_key.' '; } } } if ($chparms) { - $scrout.='

'.&mt('Obsolete parameters or stored values').': '. - $chparms.'

'.&mt('Warning!'). - '

'. - &mt('If this resource is in active use, student performance data from the previous version may become inaccessible.').'


'; + $scrout.='

'.&mt('Obsolete parameters or saved values').': ' + .$chparms.'

' + .'

'.&mt('Warning!').'
' + .&mt('If this resource is in active use, student performance data from the previous version may become inaccessible.') + .'


'; + } + if ($metadatafields{'copyright'} eq 'priv') { + $scrout.='

'.&mt('Warning!').'
' + .&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.') + .'


'; } # ------------------------------------------------------- Now have all metadata @@ -1082,44 +1191,64 @@ sub publish { $textonly=~s/\//g; $textonly=~s/\[^\<]+\<\/m\>//g; $textonly=~s/\<[^\>]*\>//g; - $textonly=~tr/A-Z/a-z/; - $textonly=~s/[\$\&][a-z]\w*//g; - $textonly=~s/[^a-z\s]//g; - - foreach ($textonly=~m/(\w+)/g) { - unless ($nokey{$_}) { - $keywords{$_}=1; - } - } - } + #this is a work simplification for german authors for present + $textonly=HTML::Entities::decode($textonly); #decode HTML-character + $textonly=Encode::Encoder::encode('utf8', $textonly); #encode to perl internal unicode + $textonly=~tr/A-ZÜÄÖ/a-züäö/; #add lowercase rule for german "Umlaute" + $textonly=~s/[\$\&][a-z]\w*//g; + $textonly=~s/[^a-z^ü^ä^ö^ß\s]//g; #dont delete german "Umlaute" + + foreach ($textonly=~m/[^\s]+/g) { #match all but whitespaces + unless ($nokey{$_}) { + $keywords{$_}=1; + } + } + + + } - foreach (split(/\W+/,$metadatafields{'keywords'})) { - $keywords{$_}=1; + foreach my $addkey (split(/[\"\'\,\;]/,$metadatafields{'keywords'})) { + $addkey=~s/\s+/ /g; + $addkey=~s/^\s//; + $addkey=~s/\s$//; + if ($addkey=~/\w/) { + $keywords{$addkey}=1; + } } # --------------------------------------------------- Now we also have keywords # ============================================================================= -# INTERACTIVE MODE -# - unless ($batch) { - $scrout.= - '
'. - '

'. - &hiddenfield('phase','two'). - &hiddenfield('filename',$ENV{'form.filename'}). - &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)). - &hiddenfield('dependencies',join(',',keys %allow)). - &textfield('Title','title',$metadatafields{'title'}). - &textfield('Author(s)','author',$metadatafields{'author'}). - &textfield('Subject','subject',$metadatafields{'subject'}); - -# --------------------------------------------------- Scan content for keywords - - my $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords"); - my $KEYWORDS=&mt('Keywords'); - my $CheckAll=&mt('check all'); - my $UncheckAll=&mt('uncheck all'); - my $keywordout=<<"END"; +# interactive mode html goes into $intr_scrout +# batch mode throws away this HTML +# additionally all of the field functions have a by product of setting +# $env{'from.'..} so that it can be used by the phase two handler in +# batch mode + + my $intr_scrout.='
' + .''; + unless ($env{'form.makeobsolete'}) { + $intr_scrout.='

' + .&mt('Searching for your resource will be based on the following metadata. Please provide as much data as possible.') + .'

' + .'

'.&mt('Cancel').'

'; + } + $intr_scrout.=&Apache::lonhtmlcommon::start_pick_box(); + $intr_scrout.= + &hiddenfield('phase','two'). + &hiddenfield('filename',$env{'form.filename'}). + &hiddenfield('allmeta',&escape($allmeta)). + &hiddenfield('dependencies',join(',',keys %allow)); + unless ($env{'form.makeobsolete'}) { + $intr_scrout.= + &textfield('Title','title',$metadatafields{'title'}). + &textfield('Author(s)','author',$metadatafields{'author'}). + &textfield('Subject','subject',$metadatafields{'subject'}); + # --------------------------------------------------- Scan content for keywords + + my $keywords_help = &Apache::loncommon::help_open_topic("Publishing_Keywords"); + my $keywordout=<<"END"; -

$KEYWORDS: - $keywords_help - - -

-
END - $keywordout.=''; - my $colcount=0; - - foreach (sort keys %keywords) { - $keywordout.='\n"; - $colcount=0; - } - $colcount++; - } - - $keywordout.='
'; - if ($colcount>10) { - $keywordout.="
'; - - $scrout.=$keywordout; - - $scrout.=&textfield('Additional Keywords','addkey',''); + $keywordout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Keywords')) + .$keywords_help + .'' + .'' + .'


' + .&Apache::loncommon::start_data_table(); + my $cols_per_row = 10; + my $colcount=0; + my $wordcount=0; + my $numkeywords = scalar(keys(%keywords)); + + foreach my $word (sort(keys(%keywords))) { + if ($colcount == 0) { + $keywordout .= &Apache::loncommon::start_data_table_row(); + } + $colcount++; + $wordcount++; + if (($wordcount == $numkeywords) && ($colcount < $cols_per_row)) { + my $colspan = 1+$cols_per_row-$colcount; + $keywordout .= ''; + } else { + $keywordout .= ''; + } + $keywordout.='