[BACK]Return to lonclonecourse.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / interface

Diff for /loncom/interface/lonclonecourse.pm between versions 1.4 and 1.17

version 1.4, 2008/01/18 17:51:18 version 1.17, 2022/03/15 18:18:31
Line 30 Line 30
 package Apache::lonclonecourse;  package Apache::lonclonecourse;
 use LONCAPA;  use LONCAPA;
 use Apache::lonnet;  use Apache::lonnet;
   use Apache::lonlocal;
   use DateTime();
   use DateTime::TimeZone;
   
 # ================================================ Get course directory listing  # ================================================ Get course directory listing
   
Line 47  sub innercrsdirlist { Line 50  sub innercrsdirlist {
     unless ($which) { $which=''; } else { $which.='/'; }      unless ($which) { $which=''; } else { $which.='/'; }
     unless ($path)  { $path=''; } else { $path.='/'; }      unless ($path)  { $path=''; } else { $path.='/'; }
     my %crsdata=&Apache::lonnet::coursedescription($courseid);      my %crsdata=&Apache::lonnet::coursedescription($courseid);
     my @listing=&Apache::lonnet::dirlist      my $getpropath = 1;
  ($which,$crsdata{'domain'},$crsdata{'num'},      my ($dirlistref,$listerror) = 
  &propath($crsdata{'domain'},$crsdata{'num'}));          &Apache::lonnet::dirlist($which,$crsdata{'domain'},
     foreach (@listing) {                                   $crsdata{'num'},$getpropath);
  unless ($_=~/^\./) {      if (ref($dirlistref) eq 'ARRAY') {
     my @unpackline = split (/\&/,$_);          foreach (@{$dirlistref}) {
     if ($unpackline[3]&$dirptr) {      unless ($_=~/^\./) {
           my @unpackline = split (/\&/,$_);
           if ($unpackline[3]&$dirptr) {
 # is a directory, recurse  # is a directory, recurse
  &innercrsdirlist($courseid,$which.$unpackline[0],      &innercrsdirlist($courseid,$which.$unpackline[0],
             $path.$unpackline[0]);       $path.$unpackline[0]);
     } else {           } else { 
 # is a file, put into output  # is a file, put into output
  push (@output,$path.$unpackline[0]);      push (@output,$path.$unpackline[0]);
           }
     }      }
  }          }
     }      }
     return @output;      return @output;
 }  }
Line 102  sub rewritefile { Line 108  sub rewritefile {
   
 sub copyfile {  sub copyfile {
     my ($origcrsid,$newcrsid,$which)=@_;      my ($origcrsid,$newcrsid,$which)=@_;
     unless ($which=~/\.sequence$/) {      unless ($which=~/\.(page|sequence)$/) {
  return &writefile($newcrsid,$which,   return &writefile($newcrsid,$which,
       &readfile($origcrsid,$which));        &readfile($origcrsid,$which));
     } else {      } else {
Line 125  sub copyfile { Line 131  sub copyfile {
 # =============================================================== Copy a dbfile  # =============================================================== Copy a dbfile
   
 sub copydb {  sub copydb {
     my ($origcrsid,$newcrsid,$which)=@_;      my ($origcrsid,$newcrsid,$which,$newinstcode,$newowner,$tinyurls)=@_;
     $which=~s/\.db$//;      $which=~s/\.db$//;
     my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);      my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
     my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);      my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);
       if (($which eq 'tiny') && ($tinyurls eq 'delete')) {
           return ();
       }
       my @info;
     my %data=&Apache::lonnet::dump      my %data=&Apache::lonnet::dump
  ($which,$origcrsdata{'domain'},$origcrsdata{'num'});   ($which,$origcrsdata{'domain'},$origcrsdata{'num'});
     foreach my $key (keys(%data)) {      foreach my $key (keys(%data)) {
  if ($key=~/^internal./) { delete($data{$key}); }   if ($key=~/^internal./) { delete($data{$key}); }
     }      }
     return &Apache::lonnet::put      if ($which =~ /^exttool_\d+$/) {
  ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});          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;
               }
           }
       } elsif ($which eq 'lti') {
           foreach my $key (keys($data)) {
               if (ref($data{$key}) eq 'HASH') {
                   if (exists($data{$key}{'usable'})) {
                       delete($data{$key}{'usable'});
                   }
               }
           }
       }
       my $putres = &Apache::lonnet::put
                        ($which,\%data,$newcrsdata{'domain'},$newcrsdata{'num'});
       return @info;
 }  }
   
 # ========================================================== Copy resourcesdata  # ========================================================== Copy resourcesdata
   
 sub copyresourcedb {  sub copyresourcedb {
     my ($origcrsid,$newcrsid)=@_;      my ($origcrsid,$newcrsid,$date_mode,$date_shift)=@_;
       my $delta=$date_shift*60*60*24;
     my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);      my %origcrsdata=&Apache::lonnet::coursedescription($origcrsid);
     my %newcrsdata= &Apache::lonnet::coursedescription($newcrsid);      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      my %data=&Apache::lonnet::dump
  ('resourcedata',$origcrsdata{'domain'},$origcrsdata{'num'});   ('resourcedata',$origcrsdata{'domain'},$origcrsdata{'num'});
     $origcrsid=~s/^\///;      $origcrsid=~s/^\///;
Line 161  sub copyresourcedb { Line 284  sub copyresourcedb {
   
  $startdate = $start{'default_enrollment_start_date'};   $startdate = $start{'default_enrollment_start_date'};
     }      }
     my $today=time;  
     my $delta=0;  
     if ($startdate) {  
  my $oneday=60*60*24;  
  $delta=$today-$startdate;  
  $delta=int($delta/$oneday)*$oneday;  
     }  
 # ugly retro fix for broken version of types  # ugly retro fix for broken version of types
     foreach (keys %data) {      foreach my $key (keys(%data)) {
  if ($_=~/\wtype$/) {   if ($key=~/\wtype$/) {
     my $newkey=$_;      my $newkey=$key;
     $newkey=~s/type$/\.type/;      $newkey=~s/type$/\.type/;
     $data{$newkey}=$data{$_};      $data{$newkey}=$data{$key};
     delete $data{$_};      delete $data{$key};
  }   }
     }      }
 # adjust symbs  # adjust symbs
     my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';      my $pattern='uploaded/'.$origcrsdata{'domain'}.'/'.$origcrsdata{'num'}.'/';
     my $new=    'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';      my $new=    'uploaded/'. $newcrsdata{'domain'}.'/'. $newcrsdata{'num'}.'/';
     foreach (keys %data) {      foreach my $key (keys(%data)) {
  if ($_=~/\Q$pattern\E/) {   if ($key=~/\Q$pattern\E/) {
     my $newkey=$_;      my $newkey=$key;
     $newkey=~s/\Q$pattern\E/$new/;      $newkey=~s/\Q$pattern\E/$new/;
     $data{$newkey}=$data{$_};      $data{$newkey}=$data{$key};
     delete $data{$_};      delete $data{$key};
  }   }
     }      }
 # adjust dates  #  transfer hash
     foreach (keys %data) {      foreach my $key (keys(%data)) {
  my $thiskey=$_;   my $thiskey=$key;
  $thiskey=~s/^$origcrsid/$newcrsid/;   $thiskey=~s/^$origcrsid/$newcrsid/;
  $newdata{$thiskey}=$data{$_};   $newdata{$thiskey}=$data{$key};
  if ($data{$_.'.type'}=~/^date_(start|end)$/) {  # date_mode empty or "preserve": transfer dates one-to-one
     if ($delta > 0) {  # date_mode "shift": shift dates by date_shift days
  $newdata{$thiskey}=$newdata{$thiskey}+$delta;  # date_mode other: do not transfer dates
     } else {          if (($date_mode) && ($date_mode ne 'preserve')) {
  # no delta, it's unlikely we want the old dates and times      if ($data{$key.'.type'}=~/^date_(start|end)$/) {
  delete($newdata{$thiskey});          if ($date_mode eq 'shift') {
  delete($newdata{$thiskey.'.type'});                      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      return &Apache::lonnet::put
  ('resourcedata',\%newdata,$newcrsdata{'domain'},$newcrsdata{'num'});   ('resourcedata',\%newdata,$newcrsdata{'domain'},$newcrsdata{'num'});
Line 216  sub copyuserfiles { Line 352  sub copyuserfiles {
     &copyfile($origcrsid,$newcrsid,$_);      &copyfile($origcrsid,$newcrsid,$_);
  }   }
     }      }
       return;
 }  }
 # ========================================================== Copy all userfiles  # ========================================================== Copy all userfiles
   
 sub copydbfiles {  sub copydbfiles {
     my ($origcrsid,$newcrsid)=@_;      my ($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls)=@_;
       my @copyinfo;
   
     my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);      my ($origcrs_discussion) = ($origcrsid=~m|^/(.*)|);
     $origcrs_discussion=~s|/|_|g;      $origcrs_discussion=~s|/|_|g;
     foreach (&crsdirlist($origcrsid)) {      foreach (&crsdirlist($origcrsid)) {
  if ($_=~/\.db$/) {          if ($_=~/\.db$/) {
     unless               unless ($_=~/^(nohist\_|disclikes|discussiontimes|classlist|versionupdate
              ($_=~/^(nohist\_|discussiontimes|classlist|versionupdate|resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations|gradingqueue|reviewqueue|CODEs|groupmembership)/) {                     |resourcedata|\Q$origcrs_discussion\E|slots|slot_reservations
  &copydb($origcrsid,$newcrsid,$_);                     |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  # ======================================================= Copy all course files
   
 sub copycoursefiles {  sub copycoursefiles {
     my ($origcrsid,$newcrsid)=@_;      my ($origcrsid,$newcrsid,$date_mode,$date_shift,$newinstcode,$newowner,
           $tinyurls)=@_;
     &copyuserfiles($origcrsid,$newcrsid);      &copyuserfiles($origcrsid,$newcrsid);
     &copydbfiles($origcrsid,$newcrsid);      my @info = &copydbfiles($origcrsid,$newcrsid,$newinstcode,$newowner,$tinyurls);
     &copyresourcedb($origcrsid,$newcrsid);      &copyresourcedb($origcrsid,$newcrsid,$date_mode,$date_shift);
       return @info;
 }  }
   
 1;  1;
Removed from v.1.4  
changed lines
  Added in v.1.17

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>