[LON-CAPA-cvs] cvs: loncom / lond lonsql /interface lonclonecourse.pm loncommon.pm londocs.pm /lonnet/perl lonnet.pm /publisher lonpublisher.pm
raeburn
raeburn at source.lon-capa.org
Thu Jul 31 11:47:25 EDT 2025
raeburn Thu Jul 31 15:47:25 2025 EDT
Modified files:
/loncom/interface lonclonecourse.pm londocs.pm loncommon.pm
/loncom/publisher lonpublisher.pm
/loncom lond lonsql
/loncom/lonnet/perl lonnet.pm
Log:
- Course cloning will copy resources in course's authoring space (both in
/priv and /res).
If homeserver for new course cloned from old course is not on current
server, lonclonecourse::copycourseauthorfiles() will be called by lonsql
via lonnet::crsauthornewcrs() -> lond -> lonsql.
-------------- next part --------------
Index: loncom/interface/lonclonecourse.pm
diff -u loncom/interface/lonclonecourse.pm:1.19 loncom/interface/lonclonecourse.pm:1.20
--- loncom/interface/lonclonecourse.pm:1.19 Thu Dec 12 17:48:15 2024
+++ loncom/interface/lonclonecourse.pm Thu Jul 31 15:47:23 2025
@@ -1,7 +1,7 @@
# The LearningOnline Network
# routines for clone a course
#
-# $Id: lonclonecourse.pm,v 1.19 2024/12/12 17:48:15 raeburn Exp $
+# $Id: lonclonecourse.pm,v 1.20 2025/07/31 15:47:23 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -28,11 +28,15 @@
###
package Apache::lonclonecourse;
-use LONCAPA;
+use LONCAPA qw(:DEFAULT :match);
use Apache::lonnet;
+use Apache::loncommon;
+use Apache::lonpublisher;
use Apache::lonlocal;
use DateTime();
use DateTime::TimeZone;
+use HTML::LCParser;
+use File::Compare;
# ================================================ Get course directory listing
@@ -124,6 +128,8 @@
=> '/public/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
'/adm/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
=> '/adm/'.$newcrsdata{'domain'}.'/'.$newcrsdata{'num'}.'/',
+ '/res/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
+ => '/res/'.$newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
)));
}
}
@@ -296,13 +302,18 @@
# adjust symbs
my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
my $new= 'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
+ my $crsrespatt = $origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
+ my $newcrsres = $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
foreach my $key (keys(%data)) {
if ($key=~/\Q$pattern\E/) {
my $newkey=$key;
$newkey=~s/\Q$pattern\E/$new/;
+ if ($newkey=~/___\d+___\Q$crsrespatt\E/) {
+ $newkey=~s/(___\d+___)\Q$crsrespatt\E/$1$newcrsres/;
+ }
$data{$newkey}=$data{$key};
delete $data{$key};
- }
+ }
}
# transfer hash
foreach my $key (keys(%data)) {
@@ -379,11 +390,646 @@
return @copyinfo;
}
+sub copycourseauthorfiles {
+ my ($oldurl,$newurl,$newowner,$crstype,$crsauthor) = @_;
+ my ($oldcdom,$oldcnum) = ($oldurl =~ m{^/($match_domain)/($match_courseid)$});
+ my $oldchome = &Apache::lonnet::homeserver($oldcnum,$oldcdom);
+ my $is_old_home;
+ my @ids=&Apache::lonnet::current_machine_ids();
+ if (($oldchome ne '') && (grep(/^\Q$oldchome\E$/, at ids))) {
+ $is_old_home = 1;
+ }
+ my $docroot = $Apache::lonnet::perlvar{'lonDocRoot'};
+ my $prv_exclude = &Apache::lonnet::priv_exclude();
+ my $prvsrcurl = "/priv/$oldcdom/$oldcnum";
+ my $ressrcurl = "/res/$oldcdom/$oldcnum";
+ my $res_exclude = &Apache::lonnet::res_exclude();
+ my (%privdirs,%privfiles);
+ &Apache::lonnet::recursedirs($is_old_home,1,undef,$prv_exclude,0,0,$prvsrcurl,'',\%privdirs,\%privfiles);
+ my (%resdirs,%resfiles);
+ &Apache::lonnet::recursedirs($is_old_home,1,undef,$res_exclude,0,0,$ressrcurl,'',\%resdirs,\%resfiles,'',1);
+ my ($newcdom,$newcnum) = ($newurl =~ m{^/($match_domain)/($match_courseid)$});
+ my $newchome = &Apache::lonnet::homeserver($newcnum,$newcdom);
+ my $is_new_home;
+ if (($newchome ne '') && (grep(/^\Q$newchome\E$/, at ids))) {
+ $is_new_home = 1;
+ }
+ my ($outcome,$privcount,$rescount);
+ if ((keys(%privdirs)) || (keys(%privfiles)) || (keys(%resdirs)) || (keys(%resfiles))) {
+ my $cancrsauthor;
+ if ($crsauthor) {
+ $cancrsauthor = 1;
+ } else {
+ my %domdefaults = &Apache::lonnet::get_domain_defaults($newcdom);
+ if ($domdefaults{$crstype.'crsauthor'}) {
+ $cancrsauthor = 1;
+ }
+ }
+ if (!$cancrsauthor) {
+#FIXME May need to remove resources, resourcedata, and update links in sequence files.
+ } elsif ($is_new_home) {
+ my %checkdeps;
+ my $prvdesturl = "/priv/$newcdom/$newcnum";
+ my $prvdesttop = $docroot.$prvdesturl;
+ my $resdesturl = "/res/$newcdom/$newcnum";
+ my $resdesttop = $docroot.$resdesturl;
+ foreach my $top ('priv','res') {
+ my $makepath = $docroot.'/'.$top;
+ foreach my $subdir ($newcdom,$newcnum) {
+ $makepath.='/'.$subdir;
+ unless (-e $makepath) {
+ unless (mkdir($makepath,0755)) {
+ last;
+ }
+ }
+ }
+ }
+ my ($rightsfile,$sourcerights,%newprivdir,%privdirmsgs,%newresdir,%resdirmsgs);
+ $rightsfile = 'default.rights';
+ $sourcerights = "$prvdesttop/$rightsfile";
+ my ($author,$setcrspriv,%currenv);
+ my ($owneruname,$ownerudom) = ($newowner =~ /^($match_username):($match_domain)$/);
+ if (($owneruname ne '') && ($ownerudom ne '')) {
+ $author = &Apache::loncommon::plainname($owneruname,$ownerudom,'firstname');
+ }
+ my $nokeyref = &Apache::lonpublisher::getnokey($Apache::lonnet::perlvar{'lonIncludes'});
+ if (-e $prvdesttop) {
+ if (keys(%privdirs)) {
+ &makecrsdirs($prvdesttop,\%privdirs,\%privdirmsgs,\%newprivdir);
+ }
+ &Apache::loncommon::crsauthor_rights($rightsfile,$prvdesttop,$docroot,
+ $newcnum,$newcdom,$author,$newowner);
+ }
+ if (-e $resdesttop) {
+ if (keys(%resdirs)) {
+ &makecrsdirs($resdesttop,\%resdirs,\%resdirmsgs,\%newresdir);
+ }
+ my $targetrights = "$resdesttop/$rightsfile";
+ if ((-e $sourcerights) && (-e "$sourcerights.meta") && (!-e $targetrights)) {
+ unless ($setcrspriv) {
+ &set_crsauthor_env($newurl,$newcdom,$newcnum,$newchome,$crstype,\%currenv);
+ $setcrspriv = 1;
+ }
+ my $output = &Apache::lonpublisher::batchpublish(undef,$sourcerights,$targetrights,
+ $nokeyref,1,$newowner);
+ }
+ }
+ if (-e $prvdesttop) {
+ $outcome = 'ok';
+ if (keys(%privfiles)) {
+ foreach my $key (keys(%privfiles)) {
+ if (ref($privfiles{$key}) eq 'HASH') {
+ my $prvsrcpath = $docroot.$prvsrcurl.'/';
+ my $prvdestpath = $docroot.$prvdesturl.'/';
+ my $ressrcpath = $docroot.$ressrcurl.'/';
+ my $resdestpath = $docroot.$resdesturl.'/';
+ unless ($key eq '/') {
+ $prvsrcpath .= "$key/";
+ $prvdestpath .= "$key/";
+ $ressrcpath .= "$key/";
+ $resdestpath .= "$key/";
+ }
+ foreach my $file (keys(%{$privfiles{$key}})) {
+ my ($ext) = ($file =~ /\.(\w+)$/);
+ my $embstyle=&Apache::loncommon::fileembstyle($ext);
+ my $src = $prvsrcpath.$file;
+ my $dest = $prvdestpath.$file;
+ my $ressrcfile = $ressrcpath.$file;
+ my $resdestfile = $resdestpath.$file;
+ my ($needpriv,$needprivmeta);
+ unless ($is_old_home) {
+ &Apache::lonnet::repcopy($ressrcfile);
+ &Apache::lonnet::repcopy($ressrcfile.'.meta');
+ }
+ if (-e $ressrcfile) {
+ unless ($is_old_home) {
+ my ($privsrc) = ( $src =~ m{^\Q$docroot\E(*)$} );
+ if (&Apache::lonnet::repcopy_crsprivfile($privsrc,$dest) eq 'ok') {
+ if (&File::Compare::compare($ressrcfile,$dest)) {
+ $needpriv = 1;
+ }
+ } else {
+ $needpriv = 1;
+ }
+ }
+ if (&File::Copy::copy($resdestfile,$dest)) {
+ if ($is_old_home) {
+ if (&File::Compare::compare($src,$dest)) {
+ $needpriv = 1;
+ }
+ }
+ } elsif ($is_old_home) {
+ $needpriv = 1;
+ }
+ if ((-e $dest) && ($embstyle eq 'ssi')) {
+ &crsres_fixup($dest,$oldcnum,$oldcdom,$newcnum,$newcdom);
+ }
+ } else {
+ $needpriv = 1;
+ }
+ if (-e $ressrcfile.'.meta') {
+ unless ($is_old_home) {
+ my ($privsrc) = ( $src =~ m{^\Q$docroot\E(*)$} );
+ if (&Apache::lonnet::repcopy_crsprivfile($privsrc.'.meta',$dest.'.meta') eq 'ok') {
+ if (&File::Compare::compare($ressrcfile.'.meta',$dest.'.meta')) {
+ $needprivmeta = 1;
+ }
+ } else {
+ $needprivmeta = 1;
+ }
+ }
+ if (&File::Copy::copy($resdestfile.'.meta',$dest.'.meta')) {
+ if ($is_old_home) {
+ if (&File::Compare::compare($src.'.meta',$dest.'.meta')) {
+ $needprivmeta = 1;
+ }
+ }
+ if (-e $dest.'.meta') {
+ &crsres_fixup_meta($dest,$oldcnum,$oldcdom,$newcnum,$newcdom,$newowner,
+ 'custom',"/res/$newcdom/$newcnum/default.rights",
+ '',\%checkdeps);
+ }
+ } else {
+ $needprivmeta = 1;
+ }
+ } else {
+ $needprivmeta = 1;
+ }
+ if ((-e $dest) && (-e $dest.'.meta')) {
+ unless ($setcrspriv) {
+ &set_crsauthor_env($newurl,$newcdom,$newcnum,$newchome,$crstype,\%currenv);
+ $setcrspriv = 1;
+ }
+ if (-e $resdestfile) {
+ unlink($resdestfile);
+ }
+ if (-e $resdestfile.'.meta') {
+ unlink($resdestfile.'.meta');
+ }
+ my $output = &Apache::lonpublisher::batchpublish(undef,$dest,$resdestfile,
+ $nokeyref,1,$newowner);
+ }
+ if ($needpriv) {
+ if ($is_old_home) {
+ if (&File::Copy::copy($src,$dest)) {
+ if ($embstyle eq 'ssi') {
+ &crsres_fixup($dest,$oldcnum,$oldcdom,$newcnum,$newcdom);
+ }
+ }
+ } else {
+ my ($privsrc) = ( $src =~ m{^\Q$docroot\E(*)$} );
+ if (&Apache::lonnet::repcopy_crsprivfile($privsrc,$dest) eq 'ok') {
+ if ($embstyle eq 'ssi') {
+ &crsres_fixup($dest,$oldcnum,$oldcdom,$newcnum,$newcdom);
+ }
+ }
+ }
+ }
+ if ($needprivmeta) {
+ if ($is_old_home) {
+ if (&File::Copy::copy($src.'.meta',$dest.'.meta')) {
+ if ($embstyle eq 'ssi') {
+ &crsres_fixup_meta($dest,$oldcnum,$oldcdom,$newcnum,$newcdom,$newowner,
+ 'custom',"/res/$newcdom/$newcnum/default.rights",
+ '',\%checkdeps);
+ }
+ }
+ } else {
+ my ($privsrc) = ( $src =~ m{^\Q$docroot\E(*)$} );
+ if (&Apache::lonnet::repcopy_crsprivfile($privsrc,$dest) eq 'ok') {
+ if ($embstyle eq 'ssi') {
+ &crsres_fixup_meta($dest,$oldcnum,$oldcdom,$newcnum,$newcdom,$newowner,
+ 'custom',"/res/$newcdom/$newcnum/default.rights",
+ '',\%checkdeps);
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ if (-e $resdesttop) {
+ $outcome = 'ok';
+ if (keys(%resfiles)) {
+ foreach my $key (keys(%resfiles)) {
+ if (ref($resfiles{$key}) eq 'HASH') {
+ my $ressrcpath = $docroot.$ressrcurl.'/';
+ my $resdestpath = $docroot.$resdesturl.'/';
+ my $prvdestpath = $docroot.$prvdesturl.'/';
+ unless ($key eq '/') {
+ $ressrcpath .= "$key/";
+ $resdestpath .= "$key/";
+ $prvdestpath .= "$key/";
+ }
+ foreach my $file (keys(%{$resfiles{$key}})) {
+ my $src = $ressrcpath.$file;
+ my $dest = $resdestpath.$file;
+ my $publish = '';
+ unless (-e $dest) {
+ my ($ext) = ($file =~ /\.(\w+)$/);
+ my $embstyle=&Apache::loncommon::fileembstyle($ext);
+ unless ($is_old_home) {
+ &Apache::lonnet::repcopy($src);
+ }
+ if (-e $src) {
+ if (&File::Copy::copy($src,$dest)) {
+ unless ($file =~ /\.\d+\.\w+$/) {
+ $publish = 1;
+ }
+ if ($embstyle eq 'ssi') {
+ &crsres_fixup($dest,$oldcnum,$oldcdom,$newcnum,$newcdom);
+ }
+ }
+ }
+ }
+ unless (-e $dest.'.meta') {
+ unless ($is_old_home) {
+ &Apache::lonnet::repcopy($src.'.meta');
+ }
+ if (-e $src.'.meta') {
+ if (&File::Copy::copy($src.'.meta',$dest.'.meta')) {
+ unless ($file =~ /\.\d+\.\w+$/) {
+ $publish = 1;
+ }
+ &crsres_fixup_meta($dest,$oldcnum,$oldcdom,$newcnum,$newcdom,$owner,
+ 'custom',"/res/$newcdom/$newcnum/default.rights",
+ '',\%checkdeps);
+ }
+ }
+ }
+ if (($publish) && ($file !~ /\.\d+\.\w+$/)) {
+ my ($delpriv,$delprivmeta);
+ if (! -e $prvdestpath.$file) {
+ &File::Copy::copy($dest,$prvdestpath.$file);
+ $delpriv = 1;
+ }
+ if (!-e $prvdestpath.$file.'.meta') {
+ &File::Copy::copy($dest.'.meta',$prvdestpath.$file.'.meta');
+ $delprivmeta = 1;
+ }
+ unless ($setcrspriv) {
+ &set_crsauthor_env($newurl,$newcdom,$newcnum,$newchome,$crstype,\%currenv);
+ $setcrspriv = 1;
+ }
+ if (-e $dest) {
+ unlink($dest);
+ }
+ if (-e $dest.'.meta') {
+ unlink($dest.'.meta');
+ }
+ my $output = &Apache::lonpublisher::batchpublish(undef,$prvdestpath.$file,$dest,
+ $nokeyref,1,$newowner);
+ if ($delpriv) {
+ unlink($prvdestpath.$file);
+ }
+ if ($delprivmeta) {
+ unlink($prvdestpath.$file.'.meta');
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ if ($setcrspriv) {
+ &unset_crsauthor_env($newurl,$newcdom,$newcnum,$newchome,$crstype,\%currenv);
+ }
+ if ($outcome eq 'ok') {
+ my (%newprivdirs,%newprivfiles,%newresdirs,%newresfiles);
+ ($privcount,$rescount) = (0,0);
+ &Apache::lonnet::recursedirs($is_new_home,1,undef,$prv_exclude,0,0,$prvdesturl,'',\%newprivdirs,\%newprivfiles);
+ foreach my $key (sort(keys(%newprivfiles))) {
+ if (ref($newprivfiles{$key}) eq 'HASH') {
+ $privcount += scalar(keys(%{$newprivfiles{$key}}));
+ }
+ }
+ my (%newresdirs,%newresfiles);
+ &Apache::lonnet::recursedirs($is_new_home,1,undef,$res_exclude,0,0,$resdesturl,'',\%newresdirs,\%newresfiles);
+ foreach my $key (sort(keys(%newresfiles))) {
+ if (ref($newresfiles{$key}) eq 'HASH') {
+ $rescount += scalar(keys(%{$newresfiles{$key}}));
+ }
+ }
+ }
+ } else {
+ ($outcome,$privcount,$rescount) =
+ &Apache::lonnet::crsauthornewcrs($oldurl,$newurl,$newowner,$crstype,$crsauthor);
+ }
+ }
+ return ($outcome,$privcount,$rescount);
+}
+
+sub makecrsdirs {
+ my ($top,$dirsref,$msgref,$newref) = @_;
+ if ((ref($dirsref) eq 'HASH') && (ref($msgref) eq 'HASH') && (ref($newref) eq 'HASH')) {
+ if (-e $top) {
+ foreach my $dir (sort(keys(%{$dirsref}))) {
+ my @dirs=split(/\//,$dir);
+ my $makepath=$destop;
+ my $fail;
+ for (my $i=0;$i<@dirs;$i++) {
+ $makepath.='/'.$dirs[$i];
+ unless (-e $makepath) {
+ unless (mkdir($makepath,0755)) {
+ $fail = 1;
+ last;
+ }
+ if (($i == scalar(@dirs)-1) && (!$fail)) {
+ $newref->{$dir} = 1;
+ }
+ }
+ }
+ if ($fail) {
+ $msgref->{$dir} = &mt('Target directory: [_1] does not exist, and could not be created.',
+ '<span class="LC_filename">'.$top.'/'.$dir.'</span>')
+ ."\n";
+ }
+ }
+ }
+ }
+}
+
+sub crsres_fixup {
+ my ($dest,$oldcnum,$oldcdom,$newcnum,$newcdom,$subdir) = @_;
+ my $oldurl = "/res/$oldcdom/$oldcnum/";
+ my $newurl = "/res/$newcdom/$newcnum/";
+ if ($subdir ne '') {
+ $newurl .= "$subdir/";
+ }
+ my $outstring='';
+ my $changes = 0;
+ my @parser;
+ $parser[0]=HTML::LCParser->new($dest);
+ $parser[-1]->xml_mode(1);
+ my $token;
+ while (@parser) {
+ while ($token=$parser[-1]->get_token) {
+ if ($token->[0] eq 'S') {
+ my $tag=$token->[1];
+ my $lctag=lc($tag);
+ my %parms=%{$token->[2]};
+ foreach my $type ('src','href','background','bgimg') {
+ foreach my $key (keys(%parms)) {
+ if ($key =~ /^$type$/i) {
+ next if (($lctag eq 'img') && ($type eq 'src') &&
+ ($parms{$key} =~ m{^data\:image/gif;base64,}));
+ if ($parms{$key} =~ m{^\Q$oldurl\E}si) {
+ $parms{$key} =~ s{^\Q$oldurl\E}{$newurl}si;
+ $changes ++;
+ }
+ }
+ }
+ }
+ # probably a <randomlabel> image type <label>
+ # or a <image> tag inside <imageresponse> or <drawimage>
+ if (($lctag eq 'label' && defined($parms{'description'}))
+ || ($lctag eq 'image') || ($lctag eq 'import')) {
+ my $next_token=$parser[-1]->get_token();
+ if ($next_token->[0] eq 'T') {
+ $next_token->[1] =~ s/[\n\r\f]+//g;
+ if ($next_token->[1] =~ m{^\Q$oldurl\E}si) {
+ $next_token->[1] =~ s{^\Q$oldurl\E}{$newurl}si;
+ $changes ++;
+ }
+ }
+ $parser[-1]->unget_token($next_token);
+ }
+ if ($lctag eq 'applet') {
+ my $havecodebase=0;
+ foreach my $key (keys(%parms)) {
+ if (lc($key) eq 'codebase') {
+ if ($parms{$key} =~ m{^\Q$oldurl\E}si) {
+ $parms{$key} =~ s{^\Q$oldurl\E}{$newurl}si;
+ $changes ++;
+ }
+ $havecodebase = 1;
+ }
+ }
+ unless ($havecodebase) {
+ foreach my $key (keys(%parms)) {
+ if ($key =~ /(archive|code|object)/i) {
+ if ($parms{$key} =~ m{^\Q$oldurl\E}si) {
+ $parms{$key} =~ s{^\Q$oldurl\E}{$newurl}si;
+ $changes ++;
+ }
+ }
+ }
+ }
+ }
+ my $newparmstring='';
+ my $endtag='';
+ foreach my $parkey (keys(%parms)) {
+ if ($parkey eq '/') {
+ $endtag=' /';
+ } else {
+ my $quote=($parms{$parkey}=~/\"/?"'":'"');
+ $newparmstring.=' '.$parkey.'='.$quote.$parms{$parkey}.$quote;
+ }
+ }
+ if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
+ $outstring.='<'.$tag.$newparmstring.$endtag.'>';
+ if ($lctag eq 'm' || $lctag eq 'answer' || $lctag eq 'display' ||
+ $lctag eq 'tex') {
+ $outstring.=&Apache::lonpublisher::get_all_text_unbalanced('/'.$lctag,\@parser);
+ } elsif ($lctag eq 'script') {
+ if ($parms{'type'} eq 'loncapa/perl') {
+ $outstring.=&Apache::lonpublisher::get_all_text_unbalanced('/'.$lctag,\@parser);
+ } else {
+ my $needsupdate;
+ my $script = &Apache::lonpublisher::get_all_text_unbalanced('/'.$lctag,\@parser);
+ if ($script =~ m{\.addMediaSrc\((["'])((?!\1).+)\1\);}) {
+ my $src = $2;
+ if ($src =~ m{^\Q$oldurl\E}si) {
+ $needsupdate = 1;
+ }
+ }
+ if ($script =~ /\(document,\s*(['"])script\1,\s*\[([^\]]+)\]\);/s) {
+ my $scriptslist = $2;
+ my @srcs = split(/\s*,\s*/,$scriptslist);
+ foreach my $src (@srcs) {
+ if ($src =~ /(["'])(?:(?!\1).)+\.js\1/) {
+ my $quote = $1;
+ my ($url) = ($src =~ m/\Q$quote\E([^$quote]+)\Q$quote\E/);
+ if ($url =~ m{^\Q$oldurl/\E}si) {
+ $needsupdate = 1;
+ }
+ }
+ }
+ }
+ if ($script =~ m{loadScript\(\s*(['"])((?:(?!\1).)+\.js)\1,\s*function}is) {
+ my $src = $2;
+ if ($src =~ m{^\Q$oldurl\E}si) {
+ $needsupdate = 1;
+ }
+ }
+ if ($needsupdate) {
+ $script =~ s{^\Q$oldurl\E}{$newurl}gsi;
+ $changes ++;
+ }
+ $outstring .= $script;
+ }
+ }
+ } elsif ($token->[0] eq 'E') {
+ if ($token->[2]) {
+ unless ($token->[1] eq 'allow') {
+ $outstring.='</'.$token->[1].'>';
+ }
+ }
+ } else {
+ $outstring.=$token->[1];
+ }
+ }
+ pop(@parser);
+ }
+ if ($changes) {
+ if (open(my $fh,'>',$dest)) {
+ print $fh $outstring;
+ close($fh);
+ }
+ }
+}
+
+sub crsres_fixup_meta {
+ my ($dest,$oldcnum,$oldcdom,$newcnum,$newcdom,$modifier,$copyright,$customdistfile,$sourceavail,$checkdeps) = @_;
+ return unless (ref($checkdeps) eq 'HASH');
+ if (open(my $fh,'<',$dest.'.meta')) {
+ my ($output,$now,$setsourceavail);
+ $now = time;
+ if (($dest =~ /\.(xml|html|htm|xhtml|xhtm)$/i) || ($dest =~ /$LONCAPA::assess_re/)) {
+ $setsourceavail = 1;
+ }
+ while (my $line=<$fh>) {
+ chomp($line);
+ if ($line eq "<authorspace>$oldcnum:$oldcdom</authorspace>") {
+ $output .= "<authorspace>$newcnum:$newcdom</authorspace>\n";
+ } elsif ($line eq '<copyright>custom</copyright>') {
+ $output .= "<copyright>$copyright</copyright>\n";
+ } elsif ($line =~ m{^\Q<creationdate>\E\d+\Q</creationdate>\E$}) {
+ $output .= "<creationdate>$now</creationdate>\n";
+ } elsif ($line eq "<customdistributionfile>/res/$oldcdom/$oldcnum/default.rights</customdistributionfile>") {
+ $output .= "<customdistributionfile>$customdistfile</customdistributionfile>\n";
+ } elsif ($line =~ m{^\Q<sourceavail\E>(open|closed)\Q</sourceavail>\E$}) {
+ if ($setsourceavail) {
+ $output .= "<sourceavail>$sourceavail</sourceavail>\n";
+ }
+ } elsif ($line eq "<domain>$oldcdom</domain>") {
+ $output .= "<domain>$newcdom</domain>\n";
+ } elsif ($line =~ m{^\Q<lastrevisiondate>\E\d+\Q</lastrevisiondate>\E$}) {
+ $output .= "<lastrevisiondate>$now</lastrevisiondate>\n";
+ } elsif ($line =~ m{^\Q<modifyinguser>\E$match_username:$match_domain\Q</modifyinguser>\E$}) {
+ $output .= "<modifyinguser>$modifier</modifyinguser>\n";
+ } elsif ($line eq "<owner>$oldcnum:$oldcdom</owner>") {
+ $output .= "<owner>$newcnum:$newcdom</owner>\n";
+ } elsif ($line =~ m{^\Q<dependencies>\E(.+)\Q</dependencies>\E$}) {
+ my @deps = split(/\s*,\s*/,$1);
+ my @newdeps;
+ my $changed = 0;
+ foreach my $dep (@deps) {
+ if ($dep =~ m{^/res/$oldcdom/$oldcnum/(.+)$}) {
+ my $rest = $1;
+ push(@newdeps,"/res/$newcdom/$newcnum/$rest");
+ $checkdeps->{$rest} = 1;
+ $changed ++;
+ } else {
+ push(@newdeps,$dep);
+ }
+ }
+ if ($changed) {
+ $output .= '<dependencies>'.join(',', at newdeps).'</dependencies>'."\n";
+ }
+ } else {
+ $output .= "$line\n";
+ }
+ }
+ close($fh);
+ if (open(my $fh,'>',$dest.'.meta')) {
+ print $fh $output;
+ close($fh);
+ }
+ }
+}
+
+sub set_crsauthor_env {
+ my ($newurl,$newcdom,$newcnum,$newchome,$crstype,$currenv) = @_;
+ if (ref($currenv) eq 'HASH') {
+ %{$currenv} = %env;
+ foreach my $key (keys(%env)) {
+ if ($key =~ /^form\./) {
+ delete($env{$key});
+ }
+ }
+ my $ccrole = 'cc';
+ if ($crstype eq 'community') {
+ $ccrole = 'co';
+ }
+ my $then=$env{'user.login.time'};
+ my $update=$env{'user.update.time'};
+ if (!$update) { $update = $then; }
+ my $refresh=$env{'user.refresh.time'};
+ if (!$refresh) { $refresh = $update; }
+ my $now = time;
+ if (&Apache::lonnet::check_adhoc_privs($newcdom,$newcnum,$update,$refresh,$now,$ccrole)) {
+ &Apache::lonnet::coursedescription($newurl);
+ &Apache::lonnet::appenv({'request.course.id' => $newcdom.'_'.$newcnum,
+ 'user.adv' => 1});
+ }
+ }
+}
+
+sub unset_crsauthor_env {
+ my ($newurl,$newcdom,$newcnum,$newchome,$crstype,$origenv) = @_;
+ my $ccrole = 'cc';
+ if ($crstype eq 'community') {
+ $ccrole = 'co';
+ }
+ my @possadded = ("request.course.id",
+ "request.course.sec",
+ "request.role",
+ "request.role.adv",
+ "request.role.domain",
+ "user.adv",
+ "user.priv.$ccrole.$newurl./",
+ "user.priv.$ccrole.$newurl./$newurl",
+ "user.priv.cm./",
+ "user.priv.cm.$newurl",
+ "user.role.$ccrole.$newurl",
+ );
+ if (ref($origenv) eq 'HASH') {
+ my (%append, at delete);
+ foreach my $item (@possadded) {
+ if (exists($origenv->{$item})) {
+ $append{$item} = $origenv->{$item};
+ } else {
+ push(@delete,$item);
+ }
+ }
+ if (keys(%append)) {
+ &Apache::lonnet::appenv(\%append,[$ccrole,'cm']);
+ }
+ if (@delete) {
+ foreach my $item (@delete) {
+ &Apache::lonnet::delenv($item,'',[$ccrole,'cm']);
+ }
+ }
+ %env = %{$origenv};
+ }
+ return;
+}
+
# ======================================================= Copy all course files
sub copycoursefiles {
my ($origcrsid,$newcrsid,$date_mode,$date_shift,$newinstcode,$newowner,
- $tinyurls)=@_;
+ $tinyurls,$crstype,$crsauthor)=@_;
+ my ($result,$privcount,$rescount) =
+ ©courseauthorfiles($origcrsid,$newcrsid,$newowner,$crstype,$crsauthor);
+ if ($result eq 'ok') {
+ &Apache::lonnet::logthis("clone courseauthored files from $origcrsid to $newcrsid for $newowner -- $privcount in /priv, $rescount in /res");
+ } elsif ($result ne '') {
+ &Apache::lonnet::logthis("clone courseauthored files from $origcrsid to $newcrsid for $newowner -- outcome: $result");
+ }
©userfiles($origcrsid,$newcrsid);
my @info = ©dbfiles($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls);
©resourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
Index: loncom/interface/londocs.pm
diff -u loncom/interface/londocs.pm:1.728 loncom/interface/londocs.pm:1.729
--- loncom/interface/londocs.pm:1.728 Sat Jun 14 02:50:25 2025
+++ loncom/interface/londocs.pm Thu Jul 31 15:47:23 2025
@@ -1,7 +1,7 @@
# The LearningOnline Network
# Documents
#
-# $Id: londocs.pm,v 1.728 2025/06/14 02:50:25 raeburn Exp $
+# $Id: londocs.pm,v 1.729 2025/07/31 15:47:23 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -959,6 +959,7 @@
$respublish = 1;
}
my $nokeyref = &Apache::lonpublisher::getnokey($r->dir_config('lonIncludes'));
+ my $modifier = "$env{'user.name'}:$env{'user.domain'}";
foreach my $file (keys(%files_to_copy)) {
my ($fail,$dup,$dir_is_file,$src,$dest,$path,$fname);
if ($file =~ m{/}) {
@@ -1021,14 +1022,14 @@
$needpriv = 1;
if (&File::Copy::copy($ressrc,$dest)) {
if ($embstyle eq 'ssi') {
- &crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd);
+ &Apache::lonclonecourse::crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd);
}
}
} else {
if (&File::Copy::copy($src,$dest)) {
$newfile{$file} = $desturl.'/'.$subdir.'/'.$file;
if ($embstyle eq 'ssi') {
- &crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd,$subdir);
+ &Apache::lonclonecourse::crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd,$subdir);
}
}
}
@@ -1039,14 +1040,14 @@
if ((-e $src.'.meta') && (!-e $dest.'.meta')) {
if (&Apache::londiff::are_different_files($src.'.meta',$ressrc.'.meta')) {
if (&File::Copy::copy($ressrc.'.meta',$dest.'.meta')) {
- &crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$copyright,
- $customdistfile,$sourceavail,\%checkdeps);
+ &Apache::lonclonecourse::crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$modifier,$copyright,
+ $customdistfile,$sourceavail,\%checkdeps);
}
$needprivmeta = 1;
} else {
if (&File::Copy::copy($src.'.meta',$dest.'.meta')) {
- &crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$copyright,
- $customdistfile,$sourceavail,\%checkdeps);
+ &Apache::lonclonecourse::crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$modifier,$copyright,
+ $customdistfile,$sourceavail,\%checkdeps);
}
}
}
@@ -1070,14 +1071,14 @@
if (&File::Copy::copy($src,$dest)) {
$newfile{$file} = $desturl.'/'.$subdir.'/'.$file;
if ($embstyle eq 'ssi') {
- &crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd,$subdir);
+ &Apache::lonclonecourse::crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd,$subdir);
}
}
}
if ($needprivmeta) {
if (&File::Copy::copy($src.'.meta',$dest.'.meta')) {
- &crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$copyright,
- $customdistfile,$sourceavail,\%checkdeps);
+ &Apache::lonclonecourse::crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$modifier,$copyright,
+ $customdistfile,$sourceavail,\%checkdeps);
}
}
} else {
@@ -1095,12 +1096,12 @@
$needpriv = 1;
if (&File::Copy::copy($docroot.$resurl.'/'.$file,$dest)) {
if ($embstyle eq 'ssi') {
- &crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd);
+ &Apache::lonclonecourse::crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd);
}
}
} else {
if ($embstyle eq 'ssi') {
- &crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd,$subdir);
+ &Apache::lonclonecourse::crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd,$subdir);
}
$newfile{$file} = $desturl.'/'.$subdir.'/'.$file;
}
@@ -1113,12 +1114,12 @@
if (&Apache::londiff::are_different_files($docroot.$resurl.'/'.$file.'.meta',$dest.'.meta')) {
$needprivmeta = 1;
if (&File::Copy::copy($docroot.$resurl.'/'.$file.'.meta',$dest.'.meta')) {
- &crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$copyright,
- $customdistfile,$sourceavail,\%checkdeps);
+ &Apache::lonclonecourse::crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$modifier,$copyright,
+ $customdistfile,$sourceavail,\%checkdeps);
}
} else {
- &crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$copyright,
- $customdistfile,$sourceavail,\%checkdeps);
+ &Apache::lonclonecourse::crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$modifier,$copyright,
+ $customdistfile,$sourceavail,\%checkdeps);
}
}
} else {
@@ -1144,15 +1145,15 @@
if ($needpriv) {
if (&Apache::lonnet::repcopy_crsprivfile($srcurl.'/'.$file,$dest) eq 'ok') {
if ($embstyle eq 'ssi') {
- &crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd,$subdir);
+ &Apache::lonclonecourse::crsres_fixup($dest,$coursenum,$coursedom,$ca,$cd,$subdir);
}
$newfile{$file} = $desturl.'/'.$subdir.'/'.$file;
}
}
if ($needprivmeta) {
if (&Apache::lonnet::repcopy_crsprivfile($srcurl.'/'.$file.'.meta',$dest.'.meta') eq 'ok') {
- &crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$copyright,
- $customdistfile,$sourceavail,\%checkdeps);
+ &Apache::lonclonecourse::crsres_fixup_meta($dest,$coursenum,$coursedom,$ca,$cd,$modifier,$copyright,
+ $customdistfile,$sourceavail,\%checkdeps);
}
}
}
@@ -1474,201 +1475,6 @@
return $output;
}
-sub crsres_fixup_meta {
- my ($dest,$coursenum,$coursedom,$ca,$cd,$copyright,$customdistfile,$sourceavail,$checkdeps) = @_;
- return unless (ref($checkdeps) eq 'HASH');
- if (open(my $fh,'<',$dest.'.meta')) {
- my ($output,$now,$setsourceavail);
- $now = time;
- if (($dest =~ /\.(xml|html|htm|xhtml|xhtm)$/i) || ($dest =~ /$LONCAPA::assess_re/)) {
- $setsourceavail = 1;
- }
- while (my $line=<$fh>) {
- chomp($line);
- if ($line eq "<authorspace>$coursenum:$coursedom</authorspace>") {
- $output .= "<authorspace>$ca:$cd</authorspace>\n";
- } elsif ($line eq '<copyright>custom</copyright>') {
- $output .= "<copyright>$copyright</copyright>\n";
- } elsif ($line =~ m{^<creationdate>\d+</creationdate>$}) {
- $output .= "<creationdate>$now</creationdate>\n";
- } elsif ($line eq "<customdistributionfile>/res/$coursedom/$coursenum/default.rights</customdistributionfile>") {
- $output .= "<customdistributionfile>$customdistfile</customdistributionfile>\n";
- } elsif ($line =~ m{^<sourceavail>(open|closed)</sourceavail>$}) {
- if ($setsourceavail) {
- $output .= "<sourceavail>$sourceavail</sourceavail>\n";
- }
- } elsif ($line eq "<domain>$coursedom</domain>") {
- $output .= "<domain>$cd</domain>\n";
- } elsif ($line =~ m{^<lastrevisiondate>\d+</lastrevisiondate>$}) {
- $output .= "<lastrevisiondate>$now</lastrevisiondate>\n";
- } elsif ($line =~ m{^<modifyinguser>$match_username:$match_domain</modifyinguser>$}) {
- $output .= "<modifyinguser>$env{'user.name'}:$env{'user.domain'}</modifyinguser>\n";
- } elsif ($line eq "<owner>$coursenum:$coursedom</owner>") {
- $output .= "<owner>$ca:$cd</owner>\n";
- } elsif ($line =~ m{^<dependencies>(.+)</dependencies>$}) {
- my @deps = split(/\s*,\s*/,$1);
- my @newdeps;
- my $changed = 0;
- foreach my $dep (@deps) {
- if ($dep =~ m{^/res/$coursedom/$coursenum/(.+)$}) {
- my $rest = $1;
- push(@newdeps,"/res/$cd/$ca/$rest");
- $checkdeps->{$rest} = 1;
- $changed ++;
- } else {
- push(@newdeps,$dep);
- }
- }
- if ($changed) {
- $output .= '<dependencies>'.join(',', at newdeps).'</dependencies>'."\n";
- }
- } else {
- $output .= "$line\n";
- }
- }
- close($fh);
- if (open(my $fh,'>',$dest.'.meta')) {
- print $fh $output;
- close($fh);
- }
- }
-}
-
-sub crsres_fixup {
- my ($dest,$coursenum,$coursedom,$ca,$cd,$subdir) = @_;
- my $outstring='';
- my $changes = 0;
- my @parser;
- $parser[0]=HTML::LCParser->new($dest);
- $parser[-1]->xml_mode(1);
- my $token;
- while (@parser) {
- while ($token=$parser[-1]->get_token) {
- if ($token->[0] eq 'S') {
- my $tag=$token->[1];
- my $lctag=lc($tag);
- my %parms=%{$token->[2]};
- foreach my $type ('src','href','background','bgimg') {
- foreach my $key (keys(%parms)) {
- if ($key =~ /^$type$/i) {
- next if (($lctag eq 'img') && ($type eq 'src') &&
- ($parms{$key} =~ m{^data\:image/gif;base64,}));
- if ($parms{$key} =~ m{^\Q/res/$coursedom/$coursenum/\E}si) {
- $parms{$key} =~ s{^\Q/res/$coursedom/$coursenum/\E}{/res/$cd/$ca/$subdir/}si;
- $changes ++;
- }
- }
- }
- }
- # probably a <randomlabel> image type <label>
- # or a <image> tag inside <imageresponse> or <drawimage>
- if (($lctag eq 'label' && defined($parms{'description'}))
- || ($lctag eq 'image') || ($lctag eq 'import')) {
- my $next_token=$parser[-1]->get_token();
- if ($next_token->[0] eq 'T') {
- $next_token->[1] =~ s/[\n\r\f]+//g;
- if ($next_token->[1] =~ m{^\Q/res/$coursedom/$coursenum/\E}si) {
- $next_token->[1] =~ s{^\Q/res/$coursedom/$coursenum/\E}{/res/$cd/$ca/$subdir/}si;
- $changes ++;
- }
- }
- $parser[-1]->unget_token($next_token);
- }
- if ($lctag eq 'applet') {
- my $havecodebase=0;
- foreach my $key (keys(%parms)) {
- if (lc($key) eq 'codebase') {
- if ($parms{$key} =~ m{^\Q/res/$coursedom/$coursenum/\E}si) {
- $parms{$key} =~ s{^\Q/res/$coursedom/$coursenum/\E}{/res/$cd/$ca/$subdir/}si;
- $changes ++;
- }
- $havecodebase = 1;
- }
- }
- unless ($havecodebase) {
- foreach my $key (keys(%parms)) {
- if ($key =~ /(archive|code|object)/i) {
- if ($parms{$key} =~ m{^\Q/res/$coursedom/$coursenum/\E}si) {
- $parms{$key} =~ s{^\Q/res/$coursedom/$coursenum/\E}{/res/$cd/$ca/$subdir/si};
- $changes ++;
- }
- }
- }
- }
- }
- my $newparmstring='';
- my $endtag='';
- foreach my $parkey (keys(%parms)) {
- if ($parkey eq '/') {
- $endtag=' /';
- } else {
- my $quote=($parms{$parkey}=~/\"/?"'":'"');
- $newparmstring.=' '.$parkey.'='.$quote.$parms{$parkey}.$quote;
- }
- }
- if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; }
- $outstring.='<'.$tag.$newparmstring.$endtag.'>';
- if ($lctag eq 'm' || $lctag eq 'answer' || $lctag eq 'display' ||
- $lctag eq 'tex') {
- $outstring.=&Apache::lonxml::get_all_text_unbalanced('/'.$lctag,\@parser);
- } elsif ($lctag eq 'script') {
- if ($parms{'type'} eq 'loncapa/perl') {
- $outstring.=&Apache::lonxml::get_all_text_unbalanced('/'.$lctag,\@parser);
- } else {
- my $needsupdate;
- my $script = &Apache::lonxml::get_all_text_unbalanced('/'.$lctag,\@parser);
- if ($script =~ m{\.addMediaSrc\((["'])((?!\1).+)\1\);}) {
- my $src = $2;
- if ($src =~ m{^\Q/res/$coursedom/$coursenum/\E}si) {
- $needsupdate = 1;
- }
- }
- if ($script =~ /\(document,\s*(['"])script\1,\s*\[([^\]]+)\]\);/s) {
- my $scriptslist = $2;
- my @srcs = split(/\s*,\s*/,$scriptslist);
- foreach my $src (@srcs) {
- if ($src =~ /(["'])(?:(?!\1).)+\.js\1/) {
- my $quote = $1;
- my ($url) = ($src =~ m/\Q$quote\E([^$quote]+)\Q$quote\E/);
- if ($url =~ m{^\Q/res/$coursedom/$coursenum/\E}si) {
- $needsupdate = 1;
- }
- }
- }
- }
- if ($script =~ m{loadScript\(\s*(['"])((?:(?!\1).)+\.js)\1,\s*function}is) {
- my $src = $2;
- if ($src =~ m{^\Q/res/$coursedom/$coursenum/\E}si) {
- $needsupdate = 1;
- }
- }
- if ($needsupdate) {
- $script =~ s{^\Q/res/$coursedom/$coursenum/\E}{/res/$cd/$ca/$subdir/gsi};
- $changes ++;
- }
- $outstring .= $script;
- }
- }
- } elsif ($token->[0] eq 'E') {
- if ($token->[2]) {
- unless ($token->[1] eq 'allow') {
- $outstring.='</'.$token->[1].'>';
- }
- }
- } else {
- $outstring.=$token->[1];
- }
- }
- pop(@parser);
- }
- if ($changes) {
- if (open(my $fh,'>',$dest)) {
- print $fh $outstring;
- close($fh);
- }
- }
-}
-
sub group_import {
my ($coursenum, $coursedom, $folder, $container, $caller, $ltitoolsref, @files) = @_;
my ($donechk,$allmaps,%hierarchy,%titles,%addedmaps,%removefrommap,
@@ -10654,7 +10460,13 @@
if ($redirect) {
my $rightsfile = 'default.rights';
my $sourcerights = "$path/$rightsfile";
- &Apache::loncommon::crsauthor_rights($rightsfile,$path,$docroot,$coursenum,$coursedom);
+ my $author=$env{'environment.firstname'}.' '.
+ $env{'environment.middlename'}.' '.
+ $env{'environment.lastname'}.' '.
+ $env{'environment.generation'};
+ $author =~ s/\s+$//;
+ &Apache::loncommon::crsauthor_rights($rightsfile,$path,$docroot,$coursenum,$coursedom,
+ $author,$env{'user.name'}.':'.$env{'user.domain'});
my $targetrights = $docroot."/res/$coursedom/$coursenum/$rightsfile";
if ((-e $sourcerights) && (-e "$sourcerights.meta")) {
if (!-e "$docroot/res/$coursedom") {
@@ -10673,11 +10485,6 @@
my $cid = $coursedom.'_'.$coursenum;
my $now = time;
if (open(my $fh,">$source.meta")) {
- my $author=$env{'environment.firstname'}.' '.
- $env{'environment.middlename'}.' '.
- $env{'environment.lastname'}.' '.
- $env{'environment.generation'};
- $author =~ s/\s+$//;
my $title = $env{'form.newresourcetitle'};
$title =~ s/^\s+|\s+$//g;
print $fh <<END;
@@ -10701,7 +10508,7 @@
<obsolete></obsolete>
<obsoletereplacement></obsoletereplacement>
<owner>$coursenum:$coursedom</owner>
-<sourceavail></sourceavail>
+<sourceavail>closed</sourceavail>
<standards></standards>
<subject></subject>
<title>$title</title>
Index: loncom/interface/loncommon.pm
diff -u loncom/interface/loncommon.pm:1.1479 loncom/interface/loncommon.pm:1.1480
--- loncom/interface/loncommon.pm:1.1479 Thu Jul 31 15:15:37 2025
+++ loncom/interface/loncommon.pm Thu Jul 31 15:47:23 2025
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1479 2025/07/31 15:15:37 raeburn Exp $
+# $Id: loncommon.pm,v 1.1480 2025/07/31 15:47:23 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -2452,7 +2452,7 @@
}
sub crsauthor_rights {
- my ($rightsfile,$path,$docroot,$cnum,$cdom) = @_;
+ my ($rightsfile,$path,$docroot,$cnum,$cdom,$author,$modifier) = @_;
my $sourcerights = "$path/$rightsfile";
my $now = time;
if (!-e $sourcerights) {
@@ -2473,11 +2473,6 @@
}
if (!-e "$sourcerights.meta") {
if (open(my $fh,">$sourcerights.meta")) {
- my $author=$env{'environment.firstname'}.' '.
- $env{'environment.middlename'}.' '.
- $env{'environment.lastname'}.' '.
- $env{'environment.generation'};
- $author =~ s/\s+$//;
print $fh <<"END";
<abstract></abstract>
@@ -2494,7 +2489,7 @@
<lastrevisiondate>$now</lastrevisiondate>
<lowestgradelevel>0</lowestgradelevel>
<mime>rights</mime>
-<modifyinguser>$env{'user.name'}:$env{'user.domain'}</modifyinguser>
+<modifyinguser>$modifier</modifyinguser>
<notes></notes>
<obsolete></obsolete>
<obsoletereplacement></obsoletereplacement>
@@ -17681,12 +17676,22 @@
args => [$showncrstype,$clonetitle],
});
my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
+ my $crstype = lc($args->{'crstype'});
+ unless (($crstype eq 'community') || ($crstype eq 'placement')) {
+ $crstype = 'unofficial';
+ if ($args->{'crscode'} ne '') {
+ $crstype = 'official';
+ } elsif ($args->{'textbook'} ne '') {
+ $crstype = 'textbook';
+ }
+ }
+ my $crsauthor = $oldcenv{'internal.crsauthor'};
# Copy all files
my @info =
&Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},
$args->{'dateshift'},$args->{'crscode'},
$args->{'ccuname'}.':'.$args->{'ccdomain'},
- $args->{'tinyurls'});
+ $args->{'tinyurls'},$crstype,$crsauthor);
if (@info) {
push(@clonemsg, at info);
}
@@ -18350,7 +18355,12 @@
# --------------------------------------------------------- Write first profile
{
- my $ip = &Apache::lonnet::get_requestor_ip($r);
+ my $ip;
+ if ((!ref($r)) && ($ENV{'REMOTE_ADDR'} eq '127.0.0.1')) {
+ $ip = '127.0.0.1';
+ } else {
+ $ip = &Apache::lonnet::get_requestor_ip($r);
+ }
my %initial_env =
("user.name" => $username,
"user.domain" => $domain,
@@ -18383,7 +18393,12 @@
}
if ($form->{'iptoken'}) {
- my $lonhost = $r->dir_config('lonHostID');
+ my $lonhost;
+ if (ref($r)) {
+ $lonhost = $r->dir_config('lonHostID');
+ } else {
+ $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
+ }
$initial_env{"user.noloadbalance"} = $lonhost;
$env{'user.noloadbalance'} = $lonhost;
}
Index: loncom/publisher/lonpublisher.pm
diff -u loncom/publisher/lonpublisher.pm:1.310 loncom/publisher/lonpublisher.pm:1.311
--- loncom/publisher/lonpublisher.pm:1.310 Thu Jul 31 15:15:36 2025
+++ loncom/publisher/lonpublisher.pm Thu Jul 31 15:47:24 2025
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# Publication Handler
#
-# $Id: lonpublisher.pm,v 1.310 2025/07/31 15:15:36 raeburn Exp $
+# $Id: lonpublisher.pm,v 1.311 2025/07/31 15:47:24 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -1634,6 +1634,8 @@
=item I<$usebuffer>
+=item I<$modifier>
+
=back
Returns:
@@ -1658,7 +1660,7 @@
#########################################
sub phasetwo {
- my ($r,$source,$target,$style,$distarget,$batch,$usebuffer)=@_;
+ my ($r,$source,$target,$style,$distarget,$batch,$usebuffer,$modifier)=@_;
$source=~s/\/+/\//g;
$target=~s/\/+/\//g;
@@ -1793,11 +1795,15 @@
$metadatafields{'obsoletereplacement'}=
$env{'form.obsoletereplacement'};
$metadatafields{'dependencies'}=$env{'form.dependencies'};
- $metadatafields{'modifyinguser'}=$env{'user.name'}.':'.
- $env{'user.domain'};
$metadatafields{'authorspace'}=$cuname.':'.$cudom;
$metadatafields{'domain'}=$cudom;
+ if (($modifier ne '') && ($modifier =~ /^$match_username:$match_domain$/)) {
+ $metadatafields{'modifyinguser'} = $modifier;
+ } else {
+ $metadatafields{'modifyinguser'}=$env{'user.name'}.':'.
+ $env{'user.domain'};
+ }
my $crsauthor;
if ($env{'request.course.id'}) {
my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
@@ -2166,7 +2172,7 @@
#########################################
sub batchpublish {
- my ($r,$srcfile,$targetfile,$nokeyref,$usebuffer)=@_;
+ my ($r,$srcfile,$targetfile,$nokeyref,$usebuffer,$modifier)=@_;
#publication pollutes %env with form.* values
my %oldenv=%env;
$srcfile=~s/\/+/\//g;
@@ -2225,10 +2231,11 @@
# $env{'form.allmeta'},$env{'form.title'},$env{'form.author'},...
if (!$error) {
if ($usebuffer) {
- my ($result,$error) = &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1,$usebuffer);
+ my ($result,$error) = &phasetwo($r,$srcfile,$targetfile,$thisembstyle,
+ $thisdistarget,1,$usebuffer,$modifier);
$output .= '<p>'.$result.'</p>';
} else {
- &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1);
+ &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1,'',$modifier);
}
}
%env=%oldenv;
Index: loncom/lond
diff -u loncom/lond:1.583 loncom/lond:1.584
--- loncom/lond:1.583 Fri Dec 27 02:32:56 2024
+++ loncom/lond Thu Jul 31 15:47:24 2025
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.583 2024/12/27 02:32:56 raeburn Exp $
+# $Id: lond,v 1.584 2025/07/31 15:47:24 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -65,7 +65,7 @@
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.583 $'; #' stupid emacs
+my $VERSION='$Revision: 1.584 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -284,6 +284,7 @@
querysend_activitylog => {remote => 1},
querysend_allusers => {remote => 1, domroles => 1},
querysend_courselog => {remote => 1},
+ querysend_clonecrsauthor => {remote => 1, content => 1, reqcrs => 1},
querysend_fetchenrollment => {remote => 1},
querysend_getinstuser => {remote => 1},
querysend_getmultinstusers => {remote => 1},
@@ -7442,7 +7443,7 @@
my ($query,$rest)=split(/\:/,$tail,2);
$query=~s/\n*$//g;
my @possqueries =
- qw(userlog courselog fetchenrollment institutionalphotos usersearch instdirsearch getinstuser getmultinstusers);
+ qw(userlog courselog fetchenrollment institutionalphotos usersearch instdirsearch getinstuser getmultinstusers clonecrsauthor);
if (grep(/^\Q$query\E$/, at possqueries)) {
$command .= '_'.$query;
} elsif ($query eq 'prepare activity log') {
Index: loncom/lonsql
diff -u loncom/lonsql:1.99 loncom/lonsql:1.100
--- loncom/lonsql:1.99 Sat Jun 22 14:29:36 2024
+++ loncom/lonsql Thu Jul 31 15:47:25 2025
@@ -3,7 +3,7 @@
# The LearningOnline Network
# lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
#
-# $Id: lonsql,v 1.99 2024/06/22 14:29:36 raeburn Exp $
+# $Id: lonsql,v 1.100 2025/07/31 15:47:25 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -104,6 +104,8 @@
use LONCAPA::Configuration;
use LONCAPA::lonmetadata();
use Apache::lonnet;
+use Apache::loncommon;
+use Apache::lonclonecourse();
use IO::Socket;
use Symbol;
@@ -113,6 +115,7 @@
use File::Find;
use localenroll;
use GDBM_File;
+use Digest::MD5;
########################################################
########################################################
@@ -489,6 +492,96 @@
$userdata{'username'} = $uname;
$userdata{'domain'} = $udom;
$result = &allusers_table_update($query,$uname,$udom,\%userdata);
+ } elsif ($query eq 'clonecrsauthor') {
+ my $oldcid = &unescape($arg1);
+ my $newcid = &unescape($arg2);
+ my ($ownername,$ownerdom,$crstype,$crsauthor) = split(/:/,&unescape($arg3));
+ my ($newcdom,$newcnum) = ($newcid =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)$});
+ if (($newcdom ne '') && ($newcnum ne '')) {
+ my $proname=&propath($newcdom,$newcnum);
+ if ($proname) {
+ my $lonidsdir = $perlvar{'lonIDsDir'};
+ if ($lonidsdir ne '') {
+ my $confname = $newcdom.'-domainconfig';
+ my $confhome = &Apache::lonnet::homeserver($confname,$newcdom);
+ if ($confhome ne 'no_host') {
+ my ($handle,$protocol,$linkname,$needlogout,$curraddr,$currcookie,$ip);
+ if (opendir(my $dirh,$lonidsdir)) {
+ while (my $fname=readdir($dirh)) {
+ if ($fname =~ m{^(\Q$confname\E_\d+_\Q$newcdom\E_\Q$confhome\E)\.id$}) {
+ $handle = $1;
+ last;
+ }
+ }
+ closedir($dirh);
+ }
+ $protocol = $Apache::lonnet::protocol{$confhome};
+ $currcookie = $ENV{'HTTP_COOKIE'};
+ $curraddr = $ENV{'REMOTE_ADDR'};
+ if ($handle) {
+ &Apache::lonnet::transfer_profile_to_env($lonidsdir,$handle);
+ $linkname = $env{'user.linkedenv'};
+ $ENV{'REMOTE_ADDR'} = '127.0.0.1';
+ } else {
+ my $form = {};
+ my $args = {};
+ $handle = &Apache::loncommon::init_user_environment(undef,$confname,$newcdom,$confhome,$form,$args);
+ if ($handle) {
+ $ENV{'REMOTE_ADDR'} = '127.0.0.1';
+ &Apache::lonnet::log($newcdom,$confname,$confhome,"Login $ENV{'REMOTE_ADDR'}");
+ $needlogout = 1;
+ $ip = $ENV{'REMOTE_ADDR'};
+ }
+ }
+ if ($handle) {
+ if ($protocol eq 'https') {
+ $ENV{'HTTP_COOKIE'} = 'lonSID='.$handle.';';
+ if (($lonidsdir) && (-e "$lonidsdir/$handle.id")) {
+ $linkname=substr(Digest::MD5::md5_hex(Digest::MD5::md5_hex(time(). {}. rand(). $$)), 0, 32).'_linked';
+ if (-e "$lonidsdir/$linkname.id") {
+ unlink("$lonidsdir/$linkname.id");
+ }
+ my $made_symlink = eval { symlink("$lonidsdir/$handle.id",
+ "$lonidsdir/$linkname.id"); 1 };
+ if ($made_symlink) {
+ $ENV{'HTTP_COOKIE'} .= ' lonLinkID='.$linkname.';';
+ &Apache::lonnet::appenv({'user.linkedenv' => $linkname});
+ }
+ }
+ } else {
+ $ENV{'HTTP_COOKIE'} = 'lonID='.$handle.';';
+ }
+ my ($outcome,$privcount,$rescount) =
+ &Apache::lonclonecourse::copycourseauthorfiles($oldcid,$newcid,
+ $ownername.':'.$ownerdom,
+ $crstype,$crsauthor);
+ $result = &escape(join('&',$outcome,$privcount,$rescount));
+ if ($curraddr ne '') {
+ $ENV{'REMOTE_ADDR'} = $curraddr;
+ } else {
+ undef($ENV{'REMOTE_ADDR'});
+ }
+ if ($currcookie ne '') {
+ $ENV{'HTTP_COOKIE'} = $currcookie;
+ } else {
+ undef($ENV{'HTTP_COOKIE'});
+ }
+ if ($needlogout) {
+ if (unlink("$lonidsdir/$handle.id")) {
+ if (($protocol eq 'https') && ($linkname =~ /^[a-f0-9]+_linked$/)) {
+ if ((-l "$lonidsdir/$linkname.id") &&
+ (readlink("$lonidsdir/$linkname.id") eq "$lonidsdir/$handle.id")) {
+ unlink("$lonidsdir/$linkname.id");
+ }
+ }
+ &Apache::lonnet::log($newcdom,$confname,$confhome,"Logout $ip");
+ }
+ }
+ }
+ }
+ }
+ }
+ }
} else {
# Sanity checking of $query needed.
# Do an sql query
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.1539 loncom/lonnet/perl/lonnet.pm:1.1540
--- loncom/lonnet/perl/lonnet.pm:1.1539 Fri Jun 6 20:36:56 2025
+++ loncom/lonnet/perl/lonnet.pm Thu Jul 31 15:47:25 2025
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1539 2025/06/06 20:36:56 raeburn Exp $
+# $Id: lonnet.pm,v 1.1540 2025/07/31 15:47:25 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -9349,8 +9349,6 @@
$type = 'official';
} elsif ($env{'course.'.$env{'request.course.id'}.'internal.textbook'} ne '') {
$type = 'textbook';
- } else {
- $type = 'unofficial';
}
}
return if ($domdefs{$type.'crsauthor'} eq '0');
@@ -12561,9 +12559,14 @@
# Recursive function to traverse either a specific user's Authoring Space
# or corresponding Published Resource Space, and populate the hash ref:
# $dirhashref with URLs of all directories, and if $filehashref hash
-# ref arg is provided, the URLs of any files, excluding versioned, .meta,
-# or .rights files in resource space, and .meta, .save, .log, .bak and
-# .rights files in Authoring Space.
+# ref arg is provided, with the URLs of any files, subject to inclusion
+# and/or exclusion based on extension.
+#
+# Versioned files will be excluded by default. In addition, a typical
+# "exclude" hash for /priv will cause .meta or .rights files to be
+# omitted, and for /res will cause .meta, .save, .log, .bak and .rights
+# files to be ommitted. A true value for the twelfth arg: $incversioned
+# can be included if it is preferred *not* to omit versioned files.
#
# Inputs:
#
@@ -12575,13 +12578,15 @@
# files which have a matching extension will be ignored.
# $nonemptydir - if true, will only populate $fileshashref hash entry for a particular
# directory with first file found (with acceptable extension).
-# $addtopdir - if true, set $dirhashref->{'/'} = 1
+# $addtopdir - if true, set $dirhashref->{'/'} = 1
# $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
# $relpath - Current path (relative to top level).
# $dirhashref - reference to hash to populate with URLs of directories (Required)
# $filehashref - reference to hash to populate with URLs of files (Optional)
# $getlastmod - if true, will set value for each key in innerhash in $filehashref
# to last modification time of file; value set to 1 otherwise.
+# $incversioned - if true, versioned files (i.e., filenames ending with:
+# .number.extension) will be included.
#
# Returns: nothing
#
@@ -12595,7 +12600,7 @@
sub recursedirs {
my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,
- $relpath,$dirhashref,$filehashref,$getlastmod) = @_;
+ $relpath,$dirhashref,$filehashref,$getlastmod,$incversioned) = @_;
return unless (ref($dirhashref) eq 'HASH');
my $docroot = $perlvar{'lonDocRoot'};
my $currpath = $docroot.$toppath;
@@ -12627,10 +12632,14 @@
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
if ($recurse) {
&recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,
- $toppath,$newpath,$dirhashref,$filehashref,$getlastmod);
+ $toppath,$newpath,$dirhashref,$filehashref,$getlastmod,
+ $incversioned);
}
} elsif (($savefile) || ($relpath eq '')) {
next if ($nonemptydir && $filecount);
+ unless ($incversioned) {
+ next if ($item =~ /\.\d+\.\w+$/);
+ }
if ($checkinc || $checkexc) {
my ($extension) = ($item =~ /\.(\w+)$/);
if ($checkinc) {
@@ -12651,7 +12660,7 @@
$value = 1;
}
if ($relpath eq '') {
- $filehashref->{'/'}{$item} = $value
+ $filehashref->{'/'}{$item} = $value;
} else {
$filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = $value;
}
@@ -12691,10 +12700,14 @@
$dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
if ($recurse) {
&recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,
- $toppath,$newpath,$dirhashref,$filehashref,$getlastmod);
+ $toppath,$newpath,$dirhashref,$filehashref,$getlastmod,
+ $incversioned);
}
} elsif (($savefile) || ($relpath eq '')) {
next if ($nonemptydir && $filecount);
+ unless ($incversioned) {
+ next if ($item =~ /\.\d+\.\w+$/);
+ }
if ($checkinc || $checkexc) {
my ($extension) = ($item =~ /\.(\w+)$/);
if ($checkinc) {
@@ -15338,6 +15351,41 @@
return $result;
}
+sub crsauthornewcrs {
+ my ($oldcid,$newcid,$newowner,$crstype,$crsauthor) = @_;
+ my ($outcome,$privcount,$rescount,$oldcdom,$oldcnum);
+ (undef,$oldcdom,$oldcnum) = split('/',$oldcid);
+ if (&is_course($oldcdom,$oldcnum)) {
+ my $homeserver = &homeserver($oldcnum,$oldcdom);
+ if ($homeserver ne 'no_host') {
+ my $queryid=&reply("querysend:clonecrsauthor:".
+ &escape($oldcid).':'.
+ &escape($newcid).':'.
+ &escape($newowner.':'.$crstype.':'.$crsauthor),$homeserver);
+ my $host=&hostname($homeserver);
+ if ($queryid !~/^\Q$host\E\_/) {
+ &logthis('clone courseauthor space invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$oldcdom);
+ return;
+ }
+ my $response = &get_query_reply($queryid);
+ my $maxtries = 5;
+ my $tries = 1;
+ while (($response=~/^timeout/) && ($tries < $maxtries)) {
+ $response = &get_query_reply($queryid);
+ $tries ++;
+ }
+ if (!&error($response) && $response ne 'refused') {
+ if ($response eq 'unavailable') {
+ $outcome = $response;
+ } else {
+ ($outcome,$privcount,$rescount) = split(/&/,&unescape($response));
+ }
+ }
+ }
+ }
+ return ($outcome,$privcount,$rescount);
+}
+
sub tokenwrapper {
my $uri=shift;
$uri=~s|^https?\://([^/]+)||;
More information about the LON-CAPA-cvs
mailing list