[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.1498 and 1.1505

version 1.1498, 2022/10/22 20:45:35 version 1.1505, 2023/03/27 18:41:07
Line 2698  sub get_domain_defaults { Line 2698  sub get_domain_defaults {
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories','ssl','autoenroll',                                    'coursecategories','ssl','autoenroll',
                                   'trust','helpsettings','wafproxy','ltisec'],$domain);                                    'trust','helpsettings','wafproxy',
                                     'ltisec','toolsec'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook','placement');      my @coursetypes = ('official','unofficial','community','textbook','placement');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
Line 2884  sub get_domain_defaults { Line 2885  sub get_domain_defaults {
         }          }
         if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {          if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
             if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {              if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
                 $domdefaults{'privhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};                  $domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
               }
           }
       }
       if (ref($domconfig{'toolsec'}) eq 'HASH') {
           if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
               $domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'};
               $domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'};
           }
           if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') {
               if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') {
                   $domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'private'}{'keys'};
             }              }
         }          }
     }      }
Line 2924  sub get_dom_instcats { Line 2936  sub get_dom_instcats {
             if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,              if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
                                       \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {                                        \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
                 $instcats = {                  $instcats = {
                                   totcodes => $totcodes,
                                 codes => \%codes,                                  codes => \%codes,
                                 codetitles => \@codetitles,                                  codetitles => \@codetitles,
                                 cat_titles => \%cat_titles,                                  cat_titles => \%cat_titles,
Line 4268  sub resizeImage { Line 4281  sub resizeImage {
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
 #                    the desired filename is in $env{"form.$formname.filename"}  #                    the desired filename is in $env{"form.$formname.filename"}
 #        $context - possible values: coursedoc, existingfile, overwrite,   #        $context - possible values: coursedoc, existingfile, overwrite, 
 #                                    canceloverwrite, scantron or ''.  #                                    canceloverwrite, scantron, toollogo  or ''.
 #                   if 'coursedoc': upload to the current course  #                   if 'coursedoc': upload to the current course
 #                   if 'existingfile': write file to tmp/overwrites directory   #                   if 'existingfile': write file to tmp/overwrites directory 
 #                   if 'canceloverwrite': delete file written to tmp/overwrites directory  #                   if 'canceloverwrite': delete file written to tmp/overwrites directory
Line 4280  sub resizeImage { Line 4293  sub resizeImage {
 #                          Section => 4, CODE => 5, FirstQuestion => 9 }).  #                          Section => 4, CODE => 5, FirstQuestion => 9 }).
 #        $allfiles - reference to hash for embedded objects  #        $allfiles - reference to hash for embedded objects
 #        $codebase - reference to hash for codebase of java objects  #        $codebase - reference to hash for codebase of java objects
 #        $desuname - username for permanent storage of uploaded file  #        $destuname - username for permanent storage of uploaded file
 #        $dsetudom - domain for permanaent storage of uploaded file  #        $destudom - domain for permanaent storage of uploaded file
 #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image   #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image 
 #        $thumbheight - height (pixels) of thumbnail to make for uploaded image  #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
 #        $resizewidth - width (pixels) to which to resize uploaded image  #        $resizewidth - width (pixels) to which to resize uploaded image
Line 4491  sub finishuserfileupload { Line 4504  sub finishuserfileupload {
     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
         my $input = $filepath.'/'.$file;          my $input = $filepath.'/'.$file;
         my $output = $filepath.'/'.'tn-'.$file;          my $output = $filepath.'/'.'tn-'.$file;
           my $makethumb; 
         my $thumbsize = $thumbwidth.'x'.$thumbheight;          my $thumbsize = $thumbwidth.'x'.$thumbheight;
         my @args = ('convert','-sample',$thumbsize,$input,$output);          if ($context eq 'toollogo') {
         system({$args[0]} @args);              my ($fullwidth,$fullheight) = &check_dimensions($input);
         if (-e $filepath.'/'.'tn-'.$file) {              if ($fullwidth ne '' && $fullheight ne '') {
             $fetchthumb  = 1;                   if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) {
                       $makethumb = 1;
                   }
               }
           } else {
               $makethumb = 1;
           }
           if ($makethumb) {
               my @args = ('convert','-sample',$thumbsize,$input,$output);
               system({$args[0]} @args);
               if (-e $filepath.'/'.'tn-'.$file) {
                   $fetchthumb  = 1; 
               }
         }          }
     }      }
     
Line 4727  sub embedded_dependency { Line 4753  sub embedded_dependency {
     return;      return;
 }  }
   
   sub check_dimensions {
       my ($inputfile) = @_;
       my ($fullwidth,$fullheight);
       if (($inputfile =~ m|^[/\w.\-]+$|) && (-e $inputfile)) {
           my $mm = new File::MMagic;
           my $mime_type = $mm->checktype_filename($inputfile);
           if ($mime_type =~ m{^image/}) {
               if (open(PIPE,"identify $inputfile 2>&1 |")) {
                   my $imageinfo = <PIPE>;
                   if (!close(PIPE)) {
                       &Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile");
                   }
                   chomp($imageinfo);
                   my ($fullsize) =
                       ($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/);
                   if ($fullsize) {
                       ($fullwidth,$fullheight) = split(/x/,$fullsize);
                   }
               }
           }
       }
       return ($fullwidth,$fullheight);
   }
   
 sub bubblesheet_converter {  sub bubblesheet_converter {
     my ($cdom,$fullpath,$config,$format) = @_;      my ($cdom,$fullpath,$config,$format) = @_;
     if ((&domain($cdom) ne '') &&      if ((&domain($cdom) ne '') &&
Line 7954  sub is_portfolio_file { Line 8004  sub is_portfolio_file {
     return;      return;
 }  }
   
   sub is_coursetool_logo {
       my ($uri) = @_;
       if ($env{'request.course.id'}) {
           my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
           if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) {
               return 1;
           }
       }
       return;
   }
   
 sub usertools_access {  sub usertools_access {
     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;      my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
     my ($access,%tools);      my ($access,%tools);
Line 8582  sub allowed { Line 8643  sub allowed {
   
     if ($env{'request.course.id'}) {      if ($env{'request.course.id'}) {
   
           if ($priv eq 'bre') {
               if (&is_coursetool_logo($uri)) {
                   return 'F';
               }
           }
   
 # If this is modifying password (internal auth) domains must match for user and user's role.  # If this is modifying password (internal auth) domains must match for user and user's role.
   
         if ($priv eq 'mip') {          if ($priv eq 'mip') {
Line 10333  sub assignrole { Line 10400  sub assignrole {
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
  unless (&allowed('ccr',$cwosec)) {          if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) {
            my $refused = 1;             my $refused = 1;
            if ($context eq 'requestcourses') {             if ($context eq 'requestcourses') {
                if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {                 if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
Line 12025  sub stat_file { Line 12092  sub stat_file {
 # or corresponding Published Resource Space, and populate the hash ref:  # or corresponding Published Resource Space, and populate the hash ref:
 # $dirhashref with URLs of all directories, and if $filehashref hash  # $dirhashref with URLs of all directories, and if $filehashref hash
 # ref arg is provided, the URLs of any files, excluding versioned, .meta,  # ref arg is provided, the URLs of any files, excluding versioned, .meta,
 # or .rights files in resource space, and .meta, .save, .log, and .bak  # or .rights files in resource space, and .meta, .save, .log, .bak and
 # files in Authoring Space.  # .rights files in Authoring Space.
 #  #
 # Inputs:  # Inputs:
 #  #
 # $is_home - true if current server is home server for user's space  # $is_home - true if current server is home server for user's space
 # $context - either: priv, or res respectively for Authoring or Resource Space.  # $recurse - if true will also traverse subdirectories recursively
 # $docroot - Document root (i.e., /home/httpd/html  # $include - reference to hash containing allowed file extensions.  If provided,
   #             files which do not have a matching extension will be ignored.
   # $exclude - reference to hash containing excluded file extensions.  If provided,
   #             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 
 # $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname  # $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname
 # $relpath - Current path (relative to top level).  # $relpath - Current path (relative to top level).
 # $dirhashref - reference to hash to populate with URLs of directories (Required)  # $dirhashref - reference to hash to populate with URLs of directories (Required)
Line 12049  sub stat_file { Line 12122  sub stat_file {
 #  #
   
 sub recursedirs {  sub recursedirs {
     my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_;      my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;
     return unless (ref($dirhashref) eq 'HASH');      return unless (ref($dirhashref) eq 'HASH');
       my $docroot = $perlvar{'lonDocRoot'};
     my $currpath = $docroot.$toppath;      my $currpath = $docroot.$toppath;
     if ($relpath) {      if ($relpath ne '') {
         $currpath .= "/$relpath";          $currpath .= "/$relpath";
     }      }
     my $savefile;      my ($savefile,$checkinc,$checkexc);
     if (ref($filehashref)) {      if (ref($filehashref)) {
         $savefile = 1;          $savefile = 1;
     }      }
       if (ref($include) eq 'HASH') {
           $checkinc = 1;
       }
       if (ref($exclude) eq 'HASH') {
           $checkexc = 1;
       }
     if ($is_home) {      if ($is_home) {
         if (opendir(my $dirh,$currpath)) {          if ((-e $currpath) && (opendir(my $dirh,$currpath))) {
               my $filecount = 0;
             foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {              foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) {
                 next if ($item eq '');                  next if ($item eq '');
                 if (-d "$currpath/$item") {                  if (-d "$currpath/$item") {
                     my $newpath;                      my $newpath;
                     if ($relpath) {                      if ($relpath ne '') {
                         $newpath = "$relpath/$item";                          $newpath = "$relpath/$item";
                     } else {                      } else {
                         $newpath = $item;                          $newpath = $item;
                     }                      }
                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;                      $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                     &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);                      if ($recurse) {
                 } elsif ($savefile) {                          &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
                     if ($context eq 'priv') {                      }
                         unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) {                  } elsif (($savefile) || ($relpath eq '')) {
                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;                      next if ($nonemptydir && $filecount);
                         }                      if ($checkinc || $checkexc) {
                     } else {                          my ($extension) = ($item =~ /\.(\w+)$/);
                         unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) {                          if ($checkinc) {
                               next unless ($extension && $include->{$extension});
                           }
                           if ($checkexc) {
                               next if ($extension && $exclude->{$extension});
                           }
                       }
                       if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
                           $dirhashref->{'/'} = 1;
                       }
                       if ($savefile) {
                           if ($relpath eq '') {
                               $filehashref->{'/'}{$item} = 1;
                           } else {
                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;                              $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
                         }                          }
                     }                      }
                       $filecount ++;
                 }                  }
             }              }
             closedir($dirh);              closedir($dirh);
Line 12092  sub recursedirs { Line 12187  sub recursedirs {
         my @dir_lines;          my @dir_lines;
         my $dirptr=16384;          my $dirptr=16384;
         if (ref($dirlistref) eq 'ARRAY') {          if (ref($dirlistref) eq 'ARRAY') {
               my $filecount = 0;
             foreach my $dir_line (sort              foreach my $dir_line (sort
                               {                                {
                                   my ($afile)=split('&',$a,2);                                    my ($afile)=split('&',$a,2);
Line 12107  sub recursedirs { Line 12203  sub recursedirs {
                     if ($relpath) {                      if ($relpath) {
                         $newpath = "$relpath/$item";                          $newpath = "$relpath/$item";
                     } else {                      } else {
                         $relpath = '/';  
                         $newpath = $item;                          $newpath = $item;
                     }                      }
                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;                      $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                     &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref);                      if ($recurse) {
                 } elsif ($savefile) {                          &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);
                     if ($context eq 'priv') {                      }
                         unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) {                  } elsif (($savefile) || ($relpath eq '')) {
                             $filehashref->{$relpath}{$item} = 1;                      next if ($nonemptydir && $filecount);
                         }                      if ($checkinc || $checkexc) {
                     } else {                          my $extension;
                         unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) {                          if ($checkinc) {
                             $filehashref->{$relpath}{$item} = 1;                              next unless ($extension && $include->{$extension});
                           }
                           if ($checkexc) {
                               next if ($extension && $exclude->{$extension});
                           }
                       }
                       if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
                           $dirhashref->{'/'} = 1;
                       }
                       if ($savefile) {
                           if ($relpath eq '') {
                               $filehashref->{'/'}{$item} = 1;
                           } else {
                               $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;
                         }                          }
                     }                      }
                       $filecount ++; 
                 }                  }
             }              }
         }          }
     }      }
       if ($addtopdir) {
           if (($relpath eq '') && (!exists($dirhashref->{'/'}))) {
               $dirhashref->{'/'} = 1;
           }
       }
     return;      return;
 }  }
   
   sub priv_exclude {
       return {
                meta => 1,
                save => 1,
                log => 1,
                bak => 1,
                rights => 1,
                DS_Store => 1,
              };
   }
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
 # gets the value of a specific preevaluated condition  # gets the value of a specific preevaluated condition
Line 12468  sub count_supptools { Line 12593  sub count_supptools {
         my $chome=&homeserver($cnum,$cdom);          my $chome=&homeserver($cnum,$cdom);
         $numexttools = 0;          $numexttools = 0;
         unless ($chome eq 'no_host') {          unless ($chome eq 'no_host') {
             my ($supplemental) = &get_supplemental($cnum,$cdom,$reload);              my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
             if (ref($supplemental) eq 'HASH') {              if (ref($supplemental) eq 'HASH') {
                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {                  if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
                     foreach my $key (keys(%{$supplemental->{'ids'}})) {                      foreach my $key (keys(%{$supplemental->{'ids'}})) {
Line 12494  sub has_unhidden_suppfiles { Line 12619  sub has_unhidden_suppfiles {
     unless (defined($cached)) {      unless (defined($cached)) {
         my $chome=&homeserver($cnum,$cdom);          my $chome=&homeserver($cnum,$cdom);
         unless ($chome eq 'no_host') {          unless ($chome eq 'no_host') {
             my ($supplemental) = &get_supplemental($cnum,$cdom,$ignorecache,$possdel);              my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
             if (ref($supplemental) eq 'HASH') {              if (ref($supplemental) eq 'HASH') {
                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {                  if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
                     foreach my $key (keys(%{$supplemental->{'ids'}})) {                      foreach my $key (keys(%{$supplemental->{'ids'}})) {
Line 12517  sub has_unhidden_suppfiles { Line 12642  sub has_unhidden_suppfiles {
     return $showsupp;      return $showsupp;
 }  }
   
 sub get_supplemental {  
     my ($cnum,$cdom,$ignorecache,$possdel)=@_;  
     my $hashid=$cnum.':'.$cdom;  
     my ($supplemental,$cached,$set_httprefs);  
     unless ($ignorecache) {  
         ($supplemental,$cached) = &is_cached_new('supplemental',$hashid);  
     }  
     unless (defined($cached)) {  
         my $chome=&homeserver($cnum,$cdom);  
         unless ($chome eq 'no_host') {  
             my ($errors,%ids,%hidden);  
             $errors =  
                 &Apache::loncommon::recurse_supplemental($cnum,$cdom,  
                                                          'supplemental.sequence',  
                                                          $errors,$possdel,\%ids,\%hidden);  
             $set_httprefs = 1;  
             if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {  
                 &Apache::lonnet::appenv({'request.course.suppupdated' => time});  
             }  
             $supplemental = {  
                                ids => \%ids,  
                                hidden => \%hidden,  
                             };  
             &do_cache_new('supplemental',$hashid,$supplemental,600);  
         }  
     }  
     return ($supplemental,$set_httprefs);  
 }  
   
 #  #
 # EXT resource caching routines  # EXT resource caching routines
 #  #
Removed from v.1.1498  
changed lines
  Added in v.1.1505

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