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

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1401 and 1.1423

version 1.1401, 2019/01/27 14:40:02 version 1.1423, 2020/07/01 20:08:58
Line 77  use CGI::Cookie; Line 77  use CGI::Cookie;
   
 use Encode;  use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab $passwdmin);
   
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
Line 101  use LONCAPA::Configuration; Line 101  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
 use LONCAPA::Lond;  use LONCAPA::Lond;
 use LONCAPA::LWPReq;  use LONCAPA::LWPReq;
   use LONCAPA::transliterate;
   
 use File::Copy;  use File::Copy;
   
Line 1081  sub find_existing_session { Line 1082  sub find_existing_session {
     return;      return;
 }  }
   
   sub delusersession {
       my ($lonid,$udom,$uname) = @_;
       my $uprimary_id = &domain($udom,'primary');
       my $uintdom = &internet_dom($uprimary_id);
       my $intdom = &internet_dom($lonid);
       my $serverhomedom = &host_domain($lonid);
       if (($uintdom ne '') && ($uintdom eq $intdom)) {
           return &reply(join(':','delusersession',
                               map {&escape($_)} ($udom,$uname)),$lonid);
       }
       return;
   }
   
 # check if user's browser sent load balancer cookie and server still has session  # check if user's browser sent load balancer cookie and server still has session
 # and is not overloaded.  # and is not overloaded.
 sub check_for_balancer_cookie {  sub check_for_balancer_cookie {
Line 1216  sub choose_server { Line 1230  sub choose_server {
     return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);      return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
 }  }
   
   sub get_course_sessions {
       my ($cnum,$cdom,$lastactivity) = @_;
       my %servers = &internet_dom_servers($cdom);
       my %returnhash;
       foreach my $server (sort(keys(%servers))) {
           my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server);
           my @pairs=split(/\&/,$rep);
           unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) {
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   if (exists($returnhash{$key})) {
                       next if ($value < $returnhash{$key});
                   }
                   $returnhash{$key}=$value;
               }
           }
       }
       return %returnhash;
   }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 1251  sub changepass { Line 1287  sub changepass {
     } elsif ($answer =~ "invalid_client") {      } elsif ($answer =~ "invalid_client") {
         &logthis("$server refused to change $uname in $udom password because ".          &logthis("$server refused to change $uname in $udom password because ".
                  "it was a reset by e-mail originating from an invalid server.");                   "it was a reset by e-mail originating from an invalid server.");
       } elsif ($answer =~ "^prioruse") {
          &logthis("$server refused to change $uname in $udom password because ".
                   "the password had been used before");
     }      }
     return $answer;      return $answer;
 }  }
Line 2244  sub inst_directory_query { Line 2283  sub inst_directory_query {
     if ($homeserver ne '') {      if ($homeserver ne '') {
         unless ($homeserver eq $perlvar{'lonHostID'}) {          unless ($homeserver eq $perlvar{'lonHostID'}) {
             if ($srch->{'srchby'} eq 'email') {              if ($srch->{'srchby'} eq 'email') {
                 my $lcrev = &get_server_loncaparev(undef,$homeserver);                  my $lcrev = &get_server_loncaparev($udom,$homeserver);
                 my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);                  my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
                 if (($major eq '' && $minor eq '') || ($major < 2) ||                  if (($major eq '' && $minor eq '') || ($major < 2) ||
                     (($major == 2) && ($minor < 12))) {                      (($major == 2) && ($minor < 12))) {
Line 2295  sub usersearch { Line 2334  sub usersearch {
         if (&host_domain($tryserver) eq $dom) {          if (&host_domain($tryserver) eq $dom) {
             unless ($tryserver eq $perlvar{'lonHostID'}) {              unless ($tryserver eq $perlvar{'lonHostID'}) {
                 if ($srch->{'srchby'} eq 'email') {                  if ($srch->{'srchby'} eq 'email') {
                     my $lcrev = &get_server_loncaparev(undef,$tryserver);                      my $lcrev = &get_server_loncaparev($dom,$tryserver);
                     my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);                      my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
                     next if (($major eq '' && $minor eq '') || ($major < 2) ||                      next if (($major eq '' && $minor eq '') || ($major < 2) ||
                              (($major == 2) && ($minor < 12)));                               (($major == 2) && ($minor < 12)));
Line 2665  sub get_domain_defaults { Line 2704  sub get_domain_defaults {
     if (ref($domconfig{'coursecategories'}) eq 'HASH') {      if (ref($domconfig{'coursecategories'}) eq 'HASH') {
         $domdefaults{'catauth'} = 'std';          $domdefaults{'catauth'} = 'std';
         $domdefaults{'catunauth'} = 'std';          $domdefaults{'catunauth'} = 'std';
         if ($domconfig{'coursecategories'}{'auth'}) {           if ($domconfig{'coursecategories'}{'auth'}) {
             $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};              $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
         }          }
         if ($domconfig{'coursecategories'}{'unauth'}) {          if ($domconfig{'coursecategories'}{'unauth'}) {
Line 2704  sub get_domain_defaults { Line 2743  sub get_domain_defaults {
     return %domdefaults;      return %domdefaults;
 }  }
   
   sub get_dom_cats {
       my ($dom) = @_;
       return unless (&domain($dom));
       my ($cats,$cached)=&is_cached_new('cats',$dom);
       unless (defined($cached)) {
           my %domconfig = &get_dom('configuration',['coursecategories'],$dom);
           if (ref($domconfig{'coursecategories'}) eq 'HASH') {
               if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') {
                   %{$cats} = %{$domconfig{'coursecategories'}{'cats'}};
               } else {
                   $cats = {};
               }
           } else {
               $cats = {};
           }
           &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600);
       }
       return $cats;
   }
   
   sub get_dom_instcats {
       my ($dom) = @_;
       return unless (&domain($dom));
       my ($instcats,$cached)=&is_cached_new('instcats',$dom);
       unless (defined($cached)) {
           my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order);
           my $totcodes = &retrieve_instcodes(\%coursecodes,$dom);
           if ($totcodes > 0) {
               my $caller = 'global';
               if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
                                         \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
                   $instcats = {
                                   codes => \%codes,
                                   codetitles => \@codetitles,
                                   cat_titles => \%cat_titles,
                                   cat_order => \%cat_order,
                               };
                   &do_cache_new('instcats',$dom,$instcats,3600);
               }
           }
       }
       return $instcats;
   }
   
   sub retrieve_instcodes {
       my ($coursecodes,$dom) = @_;
       my $totcodes;
       my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course');
       foreach my $course (keys(%courses)) {
           if (ref($courses{$course}) eq 'HASH') {
               if ($courses{$course}{'inst_code'} ne '') {
                   $$coursecodes{$course} = $courses{$course}{'inst_code'};
                   $totcodes ++;
               }
           }
       }
       return $totcodes;
   }
   
 sub course_portal_url {  sub course_portal_url {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom) = @_;
     my $chome = &homeserver($cnum,$cdom);      my $chome = &homeserver($cnum,$cdom);
Line 2720  sub course_portal_url { Line 2818  sub course_portal_url {
     return $firsturl;      return $firsturl;
 }  }
   
   # --------------------------------------------- Get domain config for passwords
   
   sub get_passwdconf {
       my ($dom) = @_;
       my (%passwdconf,$gotconf,$lookup);
       my ($result,$cached)=&is_cached_new('passwdconf',$dom);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               %passwdconf = %{$result};
               $gotconf = 1;
           }
       }
       unless ($gotconf) {
           my %domconfig = &get_dom('configuration',['passwords'],$dom);
           if (ref($domconfig{'passwords'}) eq 'HASH') {
               %passwdconf = %{$domconfig{'passwords'}};
           }
           my $cachetime = 24*60*60;
           &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
       }
       return %passwdconf;
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 3262  sub repcopy { Line 3383  sub repcopy {
     }      }
 }  }
   
   # ------------------------------------------------- Unsubscribe from a resource
   
   sub unsubscribe {
       my ($fname) = @_;
       my $answer;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
       $fname=~s/[\n\r]//g;
       my $author=$fname;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $home=homeserver($uname,$udom);
       if ($home eq 'no_host') {
           $answer = 'no_host';
       } elsif (grep { $_ eq $home } &current_machine_ids()) {
           $answer = 'home';
       } else {
           my $defdom = $perlvar{'lonDefDomain'};
           if (&will_trust('content',$defdom,$udom)) {
               $answer = reply("unsub:$fname",$home);
           } else {
               $answer = 'untrusted';
           }
       }
       return $answer;
   }
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
Line 3407  sub remove_stale_resfile { Line 3554  sub remove_stale_resfile {
                                     $stale = 1;                                      $stale = 1;
                                 }                                  }
                                 if ($stale) {                                  if ($stale) {
                                     unlink($fname);                                      if (unlink($fname)) {
                                     if ($uri!~/\.meta$/) {                                          if ($uri!~/\.meta$/) {
                                         unlink($fname.'.meta');                                              if (-e $fname.'.meta') {
                                                   unlink($fname.'.meta');
                                               }
                                           }
                                           my $unsubresult = &unsubscribe($fname);
                                           unless ($unsubresult eq 'ok') {
                                               &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
                                           }
                                           $removed = 1;
                                     }                                      }
                                     &reply("unsub:$fname",$homeserver);  
                                     $removed = 1;  
                                 }                                  }
                             }                              }
                         }                          }
Line 3562  sub can_edit_resource { Line 3715  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $cfile = $resurl;
                   } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) {
                       my ($map,$id,$res) = &decode_symb($symb);
                       if ($map =~ /\.page$/) {
                           $incourse = 1;
                           if ($env{'form.forceedit'}) {
                               $forceview = 1;
                               $cfile = $map;
                           } else {
                               $forceedit = 1;
                               $cfile =  '/adm/wrapper'.$resurl;
                           }
                       }
                 } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {                  } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 3587  sub can_edit_resource { Line 3752  sub can_edit_resource {
                     $cfile = $template;                      $cfile = $template;
                 }                  }
             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {              } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
                     $incourse = 1;                  $incourse = 1;
                     if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
                         $forceview = 1;                      $forceview = 1;
                     } else {                  } else {
                         $forceedit = 1;                      $forceedit = 1;
                     }                  }
                     $cfile = $resurl;                  $cfile = $resurl;
             } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {              } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
                 $incourse = 1;                  $incourse = 1;
                 if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
Line 3856  sub clean_filename { Line 4021  sub clean_filename {
     }      }
 # Replace spaces by underscores  # Replace spaces by underscores
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
   # Transliterate non-ascii text to ascii
       my $lang = &Apache::lonlocal::current_language();
       $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang);
 # Replace all other weird characters by nothing  # Replace all other weird characters by nothing
     $fname=~s{[^/\w\.\-]}{}g;      $fname=~s{[^/\w\.\-]}{}g;
 # Replace all .\d. sequences with _\d. so they no longer look like version  # Replace all .\d. sequences with _\d. so they no longer look like version
Line 3863  sub clean_filename { Line 4031  sub clean_filename {
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
     return $fname;      return $fname;
 }  }
   
 # This Function checks if an Image's dimensions exceed either $resizewidth (width)   # This Function checks if an Image's dimensions exceed either $resizewidth (width) 
 # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an   # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an 
 # image with the same aspect ratio as the original, but with dimensions which do   # image with the same aspect ratio as the original, but with dimensions which do 
Line 3937  sub userfileupload { Line 4106  sub userfileupload {
     $fname=&clean_filename($fname);      $fname=&clean_filename($fname);
     # See if there is anything left      # See if there is anything left
     unless ($fname) { return 'error: no uploaded file'; }      unless ($fname) { return 'error: no uploaded file'; }
       # If filename now begins with a . prepend unix timestamp _ milliseconds
       if ($fname =~ /^\./) {
           my ($s,$usec) = &gettimeofday();
           while (length($usec) < 6) {
               $usec = '0'.$usec;
           }
           $fname = $s.'_'.substr($usec,0,3).$fname;
       }
     # Files uploaded to help request form, or uploaded to "create course" page are handled differently      # Files uploaded to help request form, or uploaded to "create course" page are handled differently
     if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||      if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||
         (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||          (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||
Line 4359  sub embedded_dependency { Line 4536  sub embedded_dependency {
 sub bubblesheet_converter {  sub bubblesheet_converter {
     my ($cdom,$fullpath,$config,$format) = @_;      my ($cdom,$fullpath,$config,$format) = @_;
     if ((&domain($cdom) ne '') &&      if ((&domain($cdom) ne '') &&
         ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/$match_courseid/scantron_orig}) &&          ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
         (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {          (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
         my %csvcols = %{$config};          my (%csvcols,%csvoptions);
           if (ref($config->{'fields'}) eq 'HASH') {  
               %csvcols = %{$config->{'fields'}};
           }
           if (ref($config->{'options'}) eq 'HASH') {
               %csvoptions = %{$config->{'options'}};
           }
         my %csvbynum = reverse(%csvcols);          my %csvbynum = reverse(%csvcols);
         my %scantronconf = &get_scantron_config($format,$cdom);          my %scantronconf = &get_scantron_config($format,$cdom);
         if (keys(%scantronconf)) {          if (keys(%scantronconf)) {
Line 4375  sub bubblesheet_converter { Line 4558  sub bubblesheet_converter {
                         );                          );
             my @ordered;              my @ordered;
             foreach my $item (sort { $a <=> $b } keys(%bynum)) {              foreach my $item (sort { $a <=> $b } keys(%bynum)) {
                 push (@ordered,$bynum{$item}));                  push(@ordered,$bynum{$item});
             }              }
             my %mapstart = (              my %mapstart = (
                               CODEstart => 'CODE',                                CODEstart => 'CODE',
Line 4394  sub bubblesheet_converter { Line 4577  sub bubblesheet_converter {
             );              );
             if (open(my $fh,'<',$fullpath)) {              if (open(my $fh,'<',$fullpath)) {
                 my $output;                  my $output;
                   my %lettdig = &letter_to_digits();
                   my %diglett = reverse(%lettdig);
                   my $numletts = scalar(keys(%lettdig));
                   my $num = 0;
                 while (my $line=<$fh>) {                  while (my $line=<$fh>) {
                       $num ++;
                       next if (($num == 1) && ($csvoptions{'hdr'} == 1));
                     $line =~ s{[\r\n]+$}{};                      $line =~ s{[\r\n]+$}{};
                     my %found;                      my %found;
                     my @values = split(/,/,$line);                      my @values = split(/,/,$line);
                     my ($qstart,$record);                      my ($qstart,$record);
                     for (my $i=0; $i<@values; $i++) {                      for (my $i=0; $i<@values; $i++) {
                         if (($qstart ne '') && ($i > $qstart)) {                          if ((($qstart ne '') && ($i > $qstart)) ||
                             $found{'FirstQuestion'} .= $values[$i];                              ($csvbynum{$i} eq 'FirstQuestion')) {
                         } elsif (exists($csvbynum{$i})) {                              if ($values[$i] eq '') {
                                   $values[$i] = $scantronconf{'Qoff'};
                               } elsif ($scantronconf{'Qon'} eq 'number') {
                                   if ($values[$i] =~ /^[A-Ja-j]$/) {
                                       $values[$i] = $lettdig{uc($values[$i])};
                                   }
                               } elsif ($scantronconf{'Qon'} eq 'letter') {
                                   if ($values[$i] =~ /^[0-9]$/) {
                                       $values[$i] = $diglett{$values[$i]};
                                   }
                               } else {
                                   if ($values[$i] =~ /^[0-9A-Ja-j]$/) {
                                       my $digit;
                                       if ($values[$i] =~ /^[A-Ja-j]$/) {
                                           $digit = $lettdig{uc($values[$i])}-1;
                                           if ($values[$i] eq 'J') {
                                               $digit += $numletts;
                                           }
                                       } elsif ($values[$i] =~ /^[0-9]$/) {
                                           $digit = $values[$i]-1;
                                           if ($values[$i] eq '0') {
                                               $digit += $numletts;
                                           }
                                       }
                                       my $qval='';
                                       for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) {
                                           if ($j == $digit) {
                                               $qval .= $scantronconf{'Qon'};
                                           } else {
                                               $qval .= $scantronconf{'Qoff'};
                                           }
                                       }
                                       $values[$i] = $qval;
                                   }
                               }
                               if (length($values[$i]) > $scantronconf{'Qlength'}) {
                                   $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'});
                               }
                               my $numblank = $scantronconf{'Qlength'} - length($values[$i]);
                               if ($numblank > 0) {
                                    $values[$i] .= ($scantronconf{'Qoff'} x $numblank);
                               }
                             if ($csvbynum{$i} eq 'FirstQuestion') {                              if ($csvbynum{$i} eq 'FirstQuestion') {
                                 $qstart = $i;                                  $qstart = $i;
                                   $found{$csvbynum{$i}} = $values[$i];
                             } else {                              } else {
                                   $found{'FirstQuestion'} .= $values[$i];
                               }
                           } elsif (exists($csvbynum{$i})) {
                               if ($csvoptions{'rem'}) {
                                 $values[$i] =~ s/^\s+//;                                  $values[$i] =~ s/^\s+//;
                                 if ($csvbynum{$i} eq 'PaperID') {                              }
                                     while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) {                              if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) {
                                         $values[$i] = '0'.$values[$i];                                  while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) {
                                     }                                      $values[$i] = '0'.$values[$i];
                                 }                                  }
                             }                              }
                             $found{$csvbynum{$i}} = $values[$i];                              $found{$csvbynum{$i}} = $values[$i];
Line 4446  sub bubblesheet_converter { Line 4681  sub bubblesheet_converter {
     }      }
 }  }
   
   sub letter_to_digits {
       my %lettdig = (
                       A => 1,
                       B => 2,
                       C => 3,
                       D => 4,
                       E => 5,
                       F => 6,
                       G => 7,
                       H => 8,
                       I => 9,
                       J => 0,
                     );
       return %lettdig;
   }
   
 sub get_scantron_config {  sub get_scantron_config {
     my ($which,$cdom) = @_;      my ($which,$cdom) = @_;
     my @lines = &get_scantronformat_file($cdom);      my @lines = &get_scantronformat_file($cdom);
Line 4511  sub get_scantronformat_file { Line 4762  sub get_scantronformat_file {
             if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) {              if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) {
                 @lines = <$fh>;                  @lines = <$fh>;
                 close($fh);                  close($fh);
             }                }
         } else {          } else {
             if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) {              if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) {
                 @lines = <$fh>;                  @lines = <$fh>;
Line 6709  sub set_adhoc_privileges { Line 6960  sub set_adhoc_privileges {
     my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);      my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
     &appenv(\%userroles,[$role,'cm']);      &appenv(\%userroles,[$role,'cm']);
     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
     unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {      unless (($caller eq 'constructaccess' && $env{'request.course.id'}) ||
               ($caller eq 'tiny')) {
         &appenv( {'request.role'        => $spec,          &appenv( {'request.role'        => $spec,
                   'request.role.domain' => $dcdom,                    'request.role.domain' => $dcdom,
                   'request.course.sec'  => $sec,                    'request.course.sec'  => $sec,
Line 7969  sub allowed { Line 8221  sub allowed {
   
     if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}      if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
        =~/\Q$priv\E\&([^\:]*)/) {         =~/\Q$priv\E\&([^\:]*)/) {
         unless (($priv eq 'bro') && (!$ownaccess)) {          if ($priv eq 'mip') {
             $thisallowed.=$1;              my $rem = $1;
               if (($uri ne '') && ($env{'request.course.id'} eq $uri) &&
                   ($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) {
                   my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                   if ($cdom ne '') {
                       my %passwdconf = &get_passwdconf($cdom);
                       if (ref($passwdconf{'crsownerchg'}) eq 'HASH') {
                           if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') {
                               if (@{$passwdconf{'crsownerchg'}{'by'}}) {
                                   my @inststatuses = split(':',$env{'environment.inststatus'});
                                   unless (@inststatuses) {
                                       @inststatuses = ('default');
                                   }
                                   foreach my $status (@inststatuses) {
                                       if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) {
                                           $thisallowed.=$rem;
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           } else {
               unless (($priv eq 'bro') && (!$ownaccess)) {
                   $thisallowed.=$1;
               }
         }          }
     }      }
   
Line 7983  sub allowed { Line 8261  sub allowed {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                 my $value = $1;                  my $value = $1;
                 if ($noblockcheck) {                  my $deeplinkblock = &deeplink_check($priv,$symb,$uri);
                   if ($deeplinkblock) {
                       $thisallowed='D';
                   } elsif ($noblockcheck) {
                     $thisallowed.=$value;                      $thisallowed.=$value;
                 } else {                  } else {
                     my @blockers = &has_comm_blocking($priv,$symb,$uri);                      my @blockers = &has_comm_blocking($priv,$symb,$uri);
Line 8003  sub allowed { Line 8284  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         if ($noblockcheck) {                          my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
                           if ($deeplinkblock) {
                               $thisallowed='D';
                           } elsif ($noblockcheck) {
                             $thisallowed='F';                              $thisallowed='F';
                         } else {                          } else {
                             my @blockers = &has_comm_blocking($priv,$symb,$refuri);                              my @blockers = &has_comm_blocking($priv,$symb,$refuri);
Line 8053  sub allowed { Line 8337  sub allowed {
   
     if ($env{'request.course.id'}) {      if ($env{'request.course.id'}) {
   
   # If this is modifying password (internal auth) domains must match for user and user's role.
   
           if ($priv eq 'mip') {
               if ($env{'user.domain'} eq $env{'request.role.domain'}) {
                   return $thisallowed;
               } else {
                   return '';
               }
           }
   
        $courseprivid=$env{'request.course.id'};         $courseprivid=$env{'request.course.id'};
        if ($env{'request.course.sec'}) {         if ($env{'request.course.sec'}) {
           $courseprivid.='/'.$env{'request.course.sec'};            $courseprivid.='/'.$env{'request.course.sec'};
Line 8108  sub allowed { Line 8402  sub allowed {
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   my $value = $1;                    my $value = $1;
                   if ($priv eq 'bre') {                    if ($priv eq 'bre') {
                       if ($noblockcheck) {                        my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
                         if ($deeplinkblock) {
                             $thisallowed = 'D';
                         } elsif ($noblockcheck) {
                           $thisallowed.=$value;                            $thisallowed.=$value;
                       } else {                        } else {
                           my @blockers = &has_comm_blocking($priv,$symb,$refuri);                            my @blockers = &has_comm_blocking($priv,$symb,$refuri);
Line 8276  sub allowed { Line 8573  sub allowed {
  return 'A';   return 'A';
     } elsif ($thisallowed eq 'B') {      } elsif ($thisallowed eq 'B') {
         return 'B';          return 'B';
       } elsif ($thisallowed eq 'D') {
           return 'D';
     }      }
    return 'F';     return 'F';
 }  }
Line 8569  sub has_comm_blocking { Line 8868  sub has_comm_blocking {
 }  }
 }  }
   
   sub deeplink_check {
       my ($priv,$symb,$uri) = @_;
       return unless ($env{'request.course.id'});
       return unless ($priv eq 'bre');
       return if ($env{'request.state'} eq 'construct');
       return if ($env{'request.role.adv'});
       my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
       my (%possibles,@symbs);
       if (!$symb) {
           $symb = &symbread($uri,1,1,1,\%possibles);
       }
       if ($symb) {
           @symbs = ($symb);
       } elsif (keys(%possibles)) {
           @symbs = keys(%possibles);
       }
   
       my ($login,$switchrole,$allow);
       if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) {
           my $key = $1;
           my $tinyurl;
           my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
           if (defined($cached)) {
                $tinyurl = $result;
           } else {
                my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
                my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
                if ($currtiny{$key} ne '') {
                    $tinyurl = $currtiny{$key};
                    &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
                }
           }
           if ($tinyurl ne '') {
               my ($cnumreq,$posslogin) = split(/\&/,$tinyurl);
               if ($cnumreq eq $cnum) {
                   $login = $posslogin;
               } else {
                   $switchrole = 1;
               }
           }
       }
       foreach my $symb (@symbs) {
           last if ($allow);
           my $deeplink = &EXT("resource.0.deeplink",$symb);
           if ($deeplink eq '') {
               $allow = 1;
           } else {
               my ($listed,$scope,$access) = split(/,/,$deeplink);
               if ($access eq 'any') {
                   $allow = 1;
               } elsif ($login) {
                   if ($access eq 'only') {
                       if ($scope eq 'res') {
                           if ($symb eq $login) {
                               $allow = 1;
                           }
                       } elsif ($scope eq 'map') {
   #FIXME Compare map for $env{'request.deeplink.login'} with map for $symb
                       } elsif ($scope eq 'rec') {
   #FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb
                       }
                   } else {
                       my ($acctype,$item) = split(/:/,$access);
                       if (($acctype eq 'lti') && ($env{'user.linkprotector'})) {
                           if (grep(/^\Q$item\E$/,split(/,/,$env{'user.linkprotector'}))) {
                               my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);
                               if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.linkproturis'}))) {
                                   $allow = 1;
                               }
                           }
                       } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
                           if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
                               my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);
                               if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) {
                                   $allow = 1;
                               }
                           }
                       }
                   }
               }
           }
       }
       return if ($allow);
       return 1;
   }
   
 # -------------------------------- Deversion and split uri into path an filename     # -------------------------------- Deversion and split uri into path an filename   
   
 #  #
Line 9865  sub store_coowners { Line 10251  sub store_coowners {
 sub modifyuserauth {  sub modifyuserauth {
     my ($udom,$uname,$umode,$upass)=@_;      my ($udom,$uname,$umode,$upass)=@_;
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     unless (&allowed('mau',$udom)) { return 'refused'; }      my $allowed;
       if (&allowed('mau',$udom)) {
           $allowed = 1;
       } elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) &&
                ($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) &&
                (!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) {
           my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
           my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           if (($cdom ne '') && ($cnum ne '')) {
               my $is_owner = &is_course_owner($cdom,$cnum);
               if ($is_owner) {
                   $allowed = 1;
               }
           }
       }
       unless ($allowed) { return 'refused'; }
     &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.      &logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
              $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               $umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
              ' in domain '.$env{'request.role.domain'});                 ' in domain '.$env{'request.role.domain'});  
Line 10206  sub writecoursepref { Line 10607  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
         $course_owner,$crstype,$cnum,$context,$category)=@_;          $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     if ($context eq 'requestcourses') {      if ($context eq 'requestcourses') {
         my $can_create = 0;          my $can_create = 0;
         my ($ownername,$ownerdom) = split(':',$course_owner);          my ($ownername,$ownerdom) = split(':',$course_owner);
         if ($udom eq $ownerdom) {          if ($udom eq $ownerdom) {
             if (&usertools_access($ownername,$ownerdom,$category,undef,              my $reload;
               if (($callercontext eq 'auto') &&
                  ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
                   $reload = 'reload';
               }
               if (&usertools_access($ownername,$ownerdom,$category,$reload,
                                   $context)) {                                    $context)) {
                 $can_create = 1;                  $can_create = 1;
             }              }
Line 11945  sub EXT { Line 12351  sub EXT {
  if ($space eq 'name') {   if ($space eq 'name') {
     return $ENV{'SERVER_NAME'};      return $ENV{'SERVER_NAME'};
         }          }
       } elsif ($realm eq 'client') {
           if ($space eq 'remote_addr') {
               return $ENV{'REMOTE_ADDR'};
           }
     }      }
     return '';      return '';
 }  }
Line 12773  sub symbverify { Line 13183  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
         my $noclutter;  
         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
             $thisurl =~ s/\?.+$//;              $thisurl =~ s/\?.+$//;
             if ($map =~ m{^uploaded/.+\.page$}) {              if ($map =~ m{^uploaded/.+\.page$}) {
                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};                  $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
                 $thisurl =~ s{^\Qhttp://https://\E}{https://};                  $thisurl =~ s{^\Qhttp://https://\E}{https://};
                 $noclutter = 1;  
             }              }
         }          }
         my $ids;          my $ids;
         if ($noclutter) {          if ($map =~ m{^uploaded/.+\.page$}) {
             $ids=$bighash{'ids_'.$thisurl};              $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
         } else {          } else {
             $ids=$bighash{'ids_'.&clutter($thisurl)};              $ids=$bighash{'ids_'.&clutter($thisurl)};
         }          }
Line 13732  sub default_login_domain { Line 14140  sub default_login_domain {
     return $domain;      return $domain;
 }  }
   
   sub shared_institution {
       my ($dom) = @_;
       my $same_intdom;
       my $hostintdom = &internet_dom($perlvar{'lonHostID'});
       if ($hostintdom ne '') {
           my %iphost = &get_iphost();
           my $primary_id = &domain($dom,'primary');
           my $primary_ip = &get_host_ip($primary_id);
           if (ref($iphost{$primary_ip}) eq 'ARRAY') {
               foreach my $id (@{$iphost{$primary_ip}}) {
                   my $intdom = &internet_dom($id);
                   if ($intdom eq $hostintdom) {
                       $same_intdom = 1;
                       last;
                   }
               }
           }
       }
       return $same_intdom;
   }
   
 sub uses_sts {  sub uses_sts {
     my ($ignore_cache) = @_;      my ($ignore_cache) = @_;
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
Line 14638  BEGIN { Line 15067  BEGIN {
   
 }  }
   
   # ------------- set default texengine (domain default overrides this)
   {
       $deftex = LONCAPA::texengine();
   }
   
   # ------------- set default minimum length for passwords for internal auth users
   {
       $passwdmin = LONCAPA::passwd_min();
   }
   
 $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],  $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
  'compress_threshold'=> 20_000,   'compress_threshold'=> 20_000,
          });           });
Line 14977  prevents recursive calls to &allowed. Line 15416  prevents recursive calls to &allowed.
  2: browse allowed   2: browse allowed
  A: passphrase authentication needed   A: passphrase authentication needed
  B: access temporarily blocked because of a blocking event in a course.   B: access temporarily blocked because of a blocking event in a course.
    D: access blocked because access is required via session initiated via deep-link 
   
 =item *  =item *
   
Line 15362  Returns: Line 15802  Returns:
                       for the sheet of paper                        for the sheet of paper
       FirstName   - column that the first name starts in        FirstName   - column that the first name starts in
       FirstNameLength - number of columns that the first name spans        FirstNameLength - number of columns that the first name spans
   
       LastName    - column that the last name starts in        LastName    - column that the last name starts in
       LastNameLength - number of columns that the last name spans        LastNameLength - number of columns that the last name spans
       BubblesPerRow - number of bubbles available in each row used to        BubblesPerRow - number of bubbles available in each row used to
Removed from v.1.1401  
changed lines
  Added in v.1.1423

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