Return to lonclonecourse.pm CVS log

Up to [LON-CAPA] / loncom / interface

- Rewrite src attributes for uploaded files in composite pages when cloning.

# The LearningOnline Network
# routines for clone a course
#
# $Id: lonclonecourse.pm,v 1.16 2020/07/23 18:03:10 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
###

package Apache::lonclonecourse;
use LONCAPA;
use Apache::lonnet;
use Apache::lonlocal;
use DateTime();
use DateTime::TimeZone;

# ================================================ Get course directory listing

my @output=();

sub crsdirlist {
    my ($courseid,$which)=@_;
    @output=();
    return &innercrsdirlist($courseid,$which);
}

sub innercrsdirlist {
    my ($courseid,$which,$path)=@_;
    my $dirptr=16384;
    unless ($which) { $which=''; } else { $which.='/'; }
    unless ($path)  { $path=''; } else { $path.='/'; }
    my %crsdata=&Apache::lonnet::coursedescription($courseid);
    my $getpropath = 1;
    my ($dirlistref,$listerror) = 
        &Apache::lonnet::dirlist($which,$crsdata{'domain'},
                                 $crsdata{'num'},$getpropath);
    if (ref($dirlistref) eq 'ARRAY') {
        foreach (@{$dirlistref}) {
	    unless ($_=~/^\./) {
	        my @unpackline = split (/\&/,$_);
	        if ($unpackline[3]&$dirptr) {
# is a directory, recurse
		    &innercrsdirlist($courseid,$which.$unpackline[0],
				     $path.$unpackline[0]);
	        } else { 
# is a file, put into output
		    push (@output,$path.$unpackline[0]);
	        }
	    }
        }
    }
    return @output;
}

# ============================================================= Read a userfile

sub readfile {
    my ($courseid,$which)=@_;
    my %crsdata=&Apache::lonnet::coursedescription($courseid);
    my $file = &Apache::lonnet::getfile('/uploaded/'.$crsdata{'domain'}.'/'.
				      $crsdata{'num'}.'/'.$which);
    return $file;
}

# ============================================================ Write a userfile

sub writefile {
    (my $courseid, my $which,$env{'form.output'})=@_;
    my %crsdata=&Apache::lonnet::coursedescription($courseid);
    my $data = &Apache::lonnet::finishuserfileupload(
					  $crsdata{'num'},$crsdata{'domain'},
					  'output',$which);
    return $data;
}

# ===================================================================== Rewrite

sub rewritefile {
    my ($contents,%rewritehash)=@_;
    foreach my $pattern (keys(%rewritehash)) {
	my $new=$rewritehash{$pattern};
	$contents=~s/\Q$pattern\E/$new/gs;
    }
    return $contents;
}

# ============================================================= Copy a userfile

sub copyfile {
    my ($origcrsid,$newcrsid,$which)=@_;
    unless ($which=~/\.(page|sequence)$/) {
	return &writefile($newcrsid,$which,
		      &readfile($origcrsid,$which));
    } else {
	my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
	my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
	return &writefile($newcrsid,$which,
		 &rewritefile(
                     &readfile($origcrsid,$which),
	    (
       '/uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
    => '/uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
       '/public/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
    => '/public/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/',
       '/adm/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/'
    => '/adm/'.$newcrsdata{'domain'}.'/'.$newcrsdata{'num'}.'/',
            )));
    }
}

# =============================================================== Copy a dbfile

sub copydb {
    my ($origcrsid,$newcrsid,$which,$newinstcode,$newowner,$tinyurls)=@_;
    $which=~s/\.db$//;
    my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
    my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
    if (($which eq 'tiny') && ($tinyurls eq 'delete')) {
        return ();
    }
    my @info;
    my %data=&Apache::lonnet::dump
	($which,$origcrsdata{'domain'},$origcrsdata{'num'});
    foreach my $key (keys(%data)) {
	if ($key=~/^internal./) { delete($data{$key}); }
    }
    if ($which =~ /^exttool_\d+$/) {
        if ($origcrsdata{'description'} ne $newcrsdata{'description'}) {
            $data{'crstitle'} =~s/\Q$origcrsdata{'description'}\E/$newcrsdata{'description'}/;
        }
        if ($origcrsdata{'internal.coursecode'} ne $newinstcode) {
            $data{'crslabel'} =~ s/\Q$origcrsdata{'internal.coursecode'}\E/$newinstcode/;
        }
    } elsif ($which eq 'tiny') {
        my $oldprefix = 'uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
        my $newprefix = 'uploaded/'.$newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
        my (%domtiny,%tocreate,@todelete,$numnew,$errors);
        if (($tinyurls eq 'transfer') && (keys(%data))) {
            unless (($origcrsdata{'internal.courseowner'} eq $newowner) &&
                    ($origcrsdata{'domain'} eq $newcrsdata{'domain'})) {
                $tinyurls = 'create';
                push(@info,{
                             mt => "Action for URL shortcut(s) changed from 'transfer' to 'create' ".
                                   "because requirements of same owner and some course domain ".
                                   "for new course and original course not met.",
                             args => [],
                           });
            }
        }
        foreach my $key (keys(%data)) {
            my $code = $data{$key};
            my $newkey = $key;
            $newkey =~ s{\Q$oldprefix\E}{$newprefix}g;
            if ($tinyurls eq 'transfer') {
                $data{$newkey} = $code;
                $domtiny{$code} = $newcrsdata{'num'}.'&'.$newkey;
                push(@todelete,$key);
            } else {
                $tocreate{$newcrsdata{'num'}.'&'.$newkey} = 1;
            }
            delete($data{$key});
        }
        if (keys(%tocreate)) {
            ($numnew,$errors) = &Apache::loncommon::make_short_symbs($newcrsdata{'domain'},
                                                                     $newcrsdata{'num'},
                                                                     \%tocreate,$newowner);
            if ((ref($errors) eq 'ARRAY') && (@{$errors} > 0)) {
                push(@info,{
                            mt => 'Error(s) when creating URL shortcut(s) in new course for equivalent '.
                                  'resource(s)/folder(s) in original course: [_1]',
                            args => [join(', ',@{$errors})],
                           });
            }
            if ($numnew) {
                push(@info,{
                            mt => 'New URL shortcut(s) in new course for [quant,_1,item] to replicate '.
                                  'shortcut(s) for equivalent(s) in original course.',
                            args => [$numnew],
                           });
            }
            return @info;
        } elsif (keys(%domtiny)) {
            my $configuname = &Apache::lonnet::get_domainconfiguser($newcrsdata{'domain'});
            my $putdomres = &Apache::lonnet::put('tiny',\%domtiny,$newcrsdata{'domain'},$configuname);
            if ($putdomres eq 'ok') {
                my $delres = &Apache::lonnet::del('tiny',\@todelete,
                                                 $origcrsdata{'domain'},
                                                 $origcrsdata{'num'});

                if ($delres eq 'ok') {
                    push(@info,{
                                 mt => 'URL shortcut(s) for [quant,_1,item] transferred, and '.
                                       'now point to resource(s)/folder(s) in new course instead of '.
                                       'equivalent(s) in original course.',
                                 args => [scalar(keys(%domtiny))],
                               });
                } else {
                    push(@info,{
                                 mt => 'Failed to delete URL shortcut(s) in original course '.
                                       'when attempting to transfer to new course.',
                                 args => [],
                               });
                }
            } else {
                push(@info,{
                              mt => 'Failed to store update of target course for URL shortcut(s) in '.
                                    'domain records.',
                              args => [],
                           });
                return @info;
            }
        }
    }
    my $putres = &Apache::lonnet::put
                     ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
    return @info;
}

# ========================================================== Copy resourcesdata

sub copyresourcedb {
    my ($origcrsid,$newcrsid,$date_mode,$date_shift)=@_;
    my $delta=$date_shift*60*60*24;
    my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
    my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
    my $origtz;
    if (($date_mode) && ($date_mode ne 'preserve') && ($date_shift) && 
        (int($date_shift) == $date_shift)) {
        $origtz = $origcrsdata{'timezone'};
        if ($origtz eq '') {
            my %domdefaults = &Apache::lonnet::get_domain_defaults($origcrsdata{'domain'});
            if ($domdefaults{'timezone_def'} ne '') {
                $origtz = $domdefaults{'timezone_def'};
            }
        }
        if ($origtz eq '') {
            $origtz = 'local';
        } elsif (!DateTime::TimeZone->is_valid_name($origtz)) {
            $origtz = 'local';
        }
    }
    my %data=&Apache::lonnet::dump
	('resourcedata',$origcrsdata{'domain'},$origcrsdata{'num'});
    $origcrsid=~s/^\///;
    $origcrsid=~s/\//\_/;
    $newcrsid=~s/^\///;
    $newcrsid=~s/\//\_/;
    my %newdata=();
    undef %newdata;
    my $startdate=$data{$origcrsid.'.0.opendate'};
    if (!$startdate) {
	# now global start date for assements try the enrollment start
	my %start=&Apache::lonnet::get('environment',
				   ['default_enrollment_start_date'],
				   $origcrsdata{'domain'},$origcrsdata{'num'});

	$startdate = $start{'default_enrollment_start_date'};
    }
# ugly retro fix for broken version of types
    foreach my $key (keys(%data)) {
	if ($key=~/\wtype$/) {
	    my $newkey=$key;
	    $newkey=~s/type$/\.type/;
	    $data{$newkey}=$data{$key};
	    delete $data{$key};
	}
    }
# adjust symbs
    my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
    my $new=    'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
    foreach my $key (keys(%data)) {
	if ($key=~/\Q$pattern\E/) {
	    my $newkey=$key;
	    $newkey=~s/\Q$pattern\E/$new/;
	    $data{$newkey}=$data{$key};
	    delete $data{$key};
	}
    }
#  transfer hash
    foreach my $key (keys(%data)) {
	my $thiskey=$key;
	$thiskey=~s/^$origcrsid/$newcrsid/;
	$newdata{$thiskey}=$data{$key};
# date_mode empty or "preserve": transfer dates one-to-one
# date_mode "shift": shift dates by date_shift days
# date_mode other: do not transfer dates
        if (($date_mode) && ($date_mode ne 'preserve')) {
	    if ($data{$key.'.type'}=~/^date_(start|end)$/) {
	        if ($date_mode eq 'shift') {
                    if (($date_shift) && ($date_shift == int($date_shift))) { 
                        my $dt = DateTime->from_epoch(epoch => $newdata{$thiskey})
                                                      ->set_time_zone($origtz);
                        if (($origtz eq 'local') && (!$ENV{TZ})) {
                            $ENV{TZ} = $dt->time_zone()->name();
                        }
                        eval {
                            $dt->add(days => int($date_shift));
                        };
                        if ($@) {
                            $newdata{$thiskey} = $newdata{$thiskey}+$delta+(60*60);
                        } else {
                            $newdata{$thiskey} = $dt->epoch();
                        }
                    } else {
                        $newdata{$thiskey} = $newdata{$thiskey}+$delta;
                    }
                } else {
                    delete($newdata{$thiskey});
                    delete($newdata{$thiskey.'.type'});
                }
            }
        }
    }
    return &Apache::lonnet::put
	('resourcedata',\%newdata,$newcrsdata{'domain'},$newcrsdata{'num'});
}

# ========================================================== Copy all userfiles

sub copyuserfiles {
    my ($origcrsid,$newcrsid)=@_;
    foreach (&crsdirlist($origcrsid,'userfiles')) {
	if ($_ !~m|^scantron_|) {
	    &copyfile($origcrsid,$newcrsid,$_);
	}
    }
    return;
}
# ========================================================== Copy all userfiles

sub copydbfiles {
    my ($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls)=@_;
    my @copyinfo;

    my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);
    $origcrs_discussion=~s|/|_|g;
    foreach (&crsdirlist($origcrsid)) {
        if ($_=~/\.db$/) {
            unless ($_=~/^(nohist\_|disclikes|discussiontimes|classlist|versionupdate
                   |resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations
                   |gradingqueue|reviewqueue|CODEs|groupmembership|comm_block)/) {
                my @info = &copydb($origcrsid,$newcrsid,$_,$newinstcode,$newowner,
                                   $tinyurls);
                if (@info) {
                    push(@copyinfo,@info);
                }
            }
        }
    }
    return @copyinfo;
}

# ======================================================= Copy all course files

sub copycoursefiles {
    my ($origcrsid,$newcrsid,$date_mode,$date_shift,$newinstcode,$newowner,
        $tinyurls)=@_;
    &copyuserfiles($origcrsid,$newcrsid);
    my @info = &copydbfiles($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls);
    &copyresourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
    return @info;
}

1;