[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.1056.4.28 and 1.1093

version 1.1056.4.28, 2011/07/28 18:30:16 version 1.1093, 2010/11/10 14:44:19
Line 196  sub get_server_timezone { Line 196  sub get_server_timezone {
     }      }
 }  }
   
 sub get_server_distarch {  
     my ($lonhost,$ignore_cache) = @_;  
     if (defined($lonhost)) {  
         if (!defined(&hostname($lonhost))) {  
             return;  
         }  
         my $cachetime = 12*3600;  
         if (!$ignore_cache) {  
             my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost);  
             if (defined($cached)) {  
                 return $distarch;  
             }  
         }  
         my $rep = &reply('serverdistarch',$lonhost);  
         unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||  
                 $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||  
                 $rep eq '') {  
             return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);  
         }  
     }  
     return;  
 }  
   
 sub get_server_loncaparev {  sub get_server_loncaparev {
     my ($dom,$lonhost,$ignore_cache,$caller) = @_;      my ($dom,$lonhost,$ignore_cache,$caller) = @_;
     if (defined($lonhost)) {      if (defined($lonhost)) {
Line 287  sub get_server_homeID { Line 264  sub get_server_homeID {
     }      }
     my $cachetime = 12*3600;      my $cachetime = 12*3600;
     my $serverhomeID;      my $serverhomeID;
     if ($caller eq 'loncron') {      if ($caller eq 'loncron') { 
         my @machine_ids = &machine_ids($hostname);          my @machine_ids = &machine_ids($hostname);
         foreach my $id (@machine_ids) {          foreach my $id (@machine_ids) {
             my $response = &reply('serverhomeID',$id);              my $response = &reply('serverhomeID',$id);
Line 748  sub userload { Line 725  sub userload {
     return $userloadpercent;      return $userloadpercent;
 }  }
   
 # ------------------------------------------ Fight off request when overloaded  
   
 sub overloaderror {  
     my ($r,$checkserver)=@_;  
     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }  
     my $loadavg;  
     if ($checkserver eq $perlvar{'lonHostID'}) {  
        open(my $loadfile,'/proc/loadavg');  
        $loadavg=<$loadfile>;  
        $loadavg =~ s/\s.*//g;  
        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};  
        close($loadfile);  
     } else {  
        $loadavg=&reply('load',$checkserver);  
     }  
     my $overload=$loadavg-100;  
     if ($overload>0) {  
  $r->err_headers_out->{'Retry-After'}=$overload;  
         $r->log_error('Overload of '.$overload.' on '.$checkserver);  
         return 413;  
     }      
     return '';  
 }  
   
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
Line 789  sub spareserver { Line 742  sub spareserver {
     }      }
     foreach my $try_server (@{ $spareid{'primary'} }) {      foreach my $try_server (@{ $spareid{'primary'} }) {
         if ($uint_dom) {          if ($uint_dom) {
             next unless (&spare_can_host($udom,$uint_dom,$remotesessions,               next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
                                          $try_server));                                            $try_server));
         }          }
  ($spare_server, $lowest_load) =   ($spare_server, $lowest_load) =
     &compare_server_load($try_server, $spare_server, $lowest_load);      &compare_server_load($try_server, $spare_server, $lowest_load);
Line 831  sub compare_server_load { Line 784  sub compare_server_load {
     my $userloadans = &reply('userload',$try_server);      my $userloadans = &reply('userload',$try_server);
   
     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {      if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
         return; #didn't get a number from the server   return; #didn't get a number from the server
     }      }
   
     my $load;      my $load;
Line 1033  sub can_host_session { Line 986  sub can_host_session {
     }      }
     if ($canhost) {      if ($canhost) {
         if (ref($hostedsessions) eq 'HASH') {          if (ref($hostedsessions) eq 'HASH') {
             my $uprimary_id = &Apache::lonnet::domain($udom,'primary');  
             my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);  
             if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {              if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
                 if (($uint_dom ne '') &&                   if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {
                     (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {  
                     $canhost = 0;                      $canhost = 0;
                 } else {                  } else {
                     $canhost = 1;                      $canhost = 1;
                 }                  }
             }              }
             if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {              if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
                 if (($uint_dom ne '') &&                   if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {
                     (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) {  
                     $canhost = 1;                      $canhost = 1;
                 } else {                  } else {
                     $canhost = 0;                      $canhost = 0;
Line 2227  sub allowuploaded { Line 2176  sub allowuploaded {
 #        path to file, source of file, instruction to parse file for objects,  #        path to file, source of file, instruction to parse file for objects,
 #        ref to hash for embedded objects,  #        ref to hash for embedded objects,
 #        ref to hash for codebase of java objects.  #        ref to hash for codebase of java objects.
 #        reference to scalar to accommodate mime type determined  
 #          from File::MMagic if $parser = parse.  
 #  #
 # output: url to file (if action was uploaddoc),   # output: url to file (if action was uploaddoc), 
 #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)  #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
Line 2255  sub allowuploaded { Line 2202  sub allowuploaded {
 #  #
   
 sub process_coursefile {  sub process_coursefile {
     my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase,      my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_;
         $mimetype)=@_;  
     my $fetchresult;      my $fetchresult;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);
     if ($action eq 'propagate') {      if ($action eq 'propagate') {
Line 2284  sub process_coursefile { Line 2230  sub process_coursefile {
             close($fh);              close($fh);
             if ($parser eq 'parse') {              if ($parser eq 'parse') {
                 my $mm = new File::MMagic;                  my $mm = new File::MMagic;
                 my $type = $mm->checktype_filename($filepath.'/'.$fname);                  my $mime_type = $mm->checktype_filename($filepath.'/'.$fname);
                 if ($type eq 'text/html') {                  if ($mime_type eq 'text/html') {
                     my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);                      my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
                     unless ($parse_result eq 'ok') {                      unless ($parse_result eq 'ok') {
                         &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);                          &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
                     }                      }
                 }                  }
                 if (ref($mimetype)) {  
                     $$mimetype = $type;  
                 }  
             }              }
             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                  $home);                                   $home);
Line 2411  sub resizeImage { Line 2354  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, or ''.  #                                    canceloverwrite, 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
 #                   $context is passed as argument to &finishuserfileupload   #                   $context is passed as argument to &finishuserfileupload
 #        $subdir - directory in userfile to store the file into  #        $subdir - directory in userfile to store the file into
 #        $parser - instruction to parse file for objects ($parser = parse)      #        $parser - instruction to parse file for objects ($parser = parse)    
 #        $allfiles - reference to hash for embedded objects  #        $allfiles - reference to hash for embedded objects
Line 2426  sub resizeImage { Line 2369  sub resizeImage {
 #        $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
 #        $resizeheight - height (pixels) to which to resize uploaded image  #        $resizeheight - height (pixels) to which to resize uploaded image
 #        $mimetype - reference to scalar to accommodate mime type determined  
 #                    from File::MMagic if $parser = parse.  
 #   # 
 # output: url of file in userspace, or error: <message>   # output: url of file in userspace, or error: <message> 
 #             or /adm/notfound.html if failure to upload occurse  #             or /adm/notfound.html if failure to upload occurse
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname,      my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname,
         $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight,$mimetype)=@_;          $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }      if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$env{'form.'.$formname.'.filename'};      my $fname=$env{'form.'.$formname.'.filename'};
     $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'; }
       chop($env{'form.'.$formname});
     # 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')) ||
          ($context eq 'existingfile') || ($context eq 'canceloverwrite')) {           ($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
         my $now = time;          my $now = time;
         my $filepath;          my $filepath;
         if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) {          if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { 
              $filepath = 'tmp/helprequests/'.$now;               $filepath = 'tmp/helprequests/'.$now;
         } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) {          } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) {
              $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.               $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}.
Line 2510  sub userfileupload { Line 2452  sub userfileupload {
             return &finishuserfileupload($docuname,$docudom,              return &finishuserfileupload($docuname,$docudom,
  $formname,$fname,$parser,$allfiles,   $formname,$fname,$parser,$allfiles,
  $codebase,$thumbwidth,$thumbheight,   $codebase,$thumbwidth,$thumbheight,
                                          $resizewidth,$resizeheight,$context,$mimetype);                                           $resizewidth,$resizeheight,$context);
         } else {          } else {
             $fname=$env{'form.folder'}.'/'.$fname;              $fname=$env{'form.folder'}.'/'.$fname;
             return &process_coursefile('uploaddoc',$docuname,$docudom,              return &process_coursefile('uploaddoc',$docuname,$docudom,
        $fname,$formname,$parser,         $fname,$formname,$parser,
        $allfiles,$codebase,$mimetype);         $allfiles,$codebase);
         }          }
     } elsif (defined($destuname)) {      } elsif (defined($destuname)) {
         my $docuname=$destuname;          my $docuname=$destuname;
Line 2523  sub userfileupload { Line 2465  sub userfileupload {
  return &finishuserfileupload($docuname,$docudom,$formname,$fname,   return &finishuserfileupload($docuname,$docudom,$formname,$fname,
      $parser,$allfiles,$codebase,       $parser,$allfiles,$codebase,
                                      $thumbwidth,$thumbheight,                                       $thumbwidth,$thumbheight,
                                      $resizewidth,$resizeheight,$context,$mimetype);                                       $resizewidth,$resizeheight,$context);
     } else {      } else {
         my $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
         my $docudom=$env{'user.domain'};          my $docudom=$env{'user.domain'};
Line 2534  sub userfileupload { Line 2476  sub userfileupload {
  return &finishuserfileupload($docuname,$docudom,$formname,$fname,   return &finishuserfileupload($docuname,$docudom,$formname,$fname,
      $parser,$allfiles,$codebase,       $parser,$allfiles,$codebase,
                                      $thumbwidth,$thumbheight,                                       $thumbwidth,$thumbheight,
                                      $resizewidth,$resizeheight,$context,$mimetype);                                       $resizewidth,$resizeheight,$context);
     }      }
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
     my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,      my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase,
         $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context,$mimetype) = @_;          $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
       
Line 2571  sub finishuserfileupload { Line 2513  sub finishuserfileupload {
             my $target = $filepath.'/'.$file;              my $target = $filepath.'/'.$file;
             if (-e $source) {              if (-e $source) {
                 my @info = stat($source);                  my @info = stat($source);
                 if ($info[9] eq $env{'form.timestamp'}) {                  if ($info[9] eq $env{'form.timestamp'}) {   
                     unless (&File::Copy::move($source,$target)) {                      unless (&File::Copy::move($source,$target)) {
                         &logthis('Failed to overwrite '.$filepath.'/'.$file);                          &logthis('Failed to overwrite '.$filepath.'/'.$file);
                         return "Moving from $source failed";                          return "Moving from $source failed";
Line 2582  sub finishuserfileupload { Line 2524  sub finishuserfileupload {
             } else {              } else {
                 return "Temporary file: $source missing";                  return "Temporary file: $source missing";
             }              }
  } elsif (!print FH ($env{'form.'.$formname})) {          } elsif (!print FH ($env{'form.'.$formname})) {
     &logthis('Failed to write to '.$filepath.'/'.$file);      &logthis('Failed to write to '.$filepath.'/'.$file);
     print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");      print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
     return '/adm/notfound.html';      return '/adm/notfound.html';
Line 2598  sub finishuserfileupload { Line 2540  sub finishuserfileupload {
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $mm = new File::MMagic;          my $mm = new File::MMagic;
         my $type = $mm->checktype_filename($filepath.'/'.$file);          my $mime_type = $mm->checktype_filename($filepath.'/'.$file);
         if ($type eq 'text/html') {          if ($mime_type eq 'text/html') {
             my $parse_result = &extract_embedded_items($filepath.'/'.$file,              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
                                                        $allfiles,$codebase);                                                         $allfiles,$codebase);
             unless ($parse_result eq 'ok') {              unless ($parse_result eq 'ok') {
Line 2607  sub finishuserfileupload { Line 2549  sub finishuserfileupload {
            ' for embedded media: '.$parse_result);              ' for embedded media: '.$parse_result); 
             }              }
         }          }
         if (ref($mimetype)) {  
             $$mimetype = $type;  
         }  
     }      }
     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
         my $input = $filepath.'/'.$file;          my $input = $filepath.'/'.$file;
Line 3143  sub get_my_roles { Line 3082  sub get_my_roles {
     unless (defined($uname)) { $uname=$env{'user.name'}; }      unless (defined($uname)) { $uname=$env{'user.name'}; }
     unless (defined($udom)) { $udom=$env{'user.domain'}; }      unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my (%dumphash,%nothide);      my (%dumphash,%nothide);
     if ($context eq 'userroles') {       if ($context eq 'userroles') {
         my $extra = &freeze_escape({'skipcheck' => 1});          my $extra = &freeze_escape({'skipcheck' => 1});
         %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);          %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
     } else {      } else {
Line 3473  sub get_domain_roles { Line 3412  sub get_domain_roles {
     return %personnel;      return %personnel;
 }  }
   
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Interval timing 
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb)=@_;      my ($type,$argsymb)=@_;
Line 3509  sub set_first_access { Line 3448  sub set_first_access {
     return 'already_set';      return 'already_set';
 }  }
   
 sub checkout {  
     my ($symb,$tuname,$tudom,$tcrsid)=@_;  
     my $now=time;  
     my $lonhost=$perlvar{'lonHostID'};  
     my $infostr=&escape(  
                  'CHECKOUTTOKEN&'.  
                  $tuname.'&'.  
                  $tudom.'&'.  
                  $tcrsid.'&'.  
                  $symb.'&'.  
  $now.'&'.$ENV{'REMOTE_ADDR'});  
     my $token=&reply('tmpput:'.$infostr,$lonhost);  
     if ($token=~/^error\:/) {   
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
         return '';   
     }  
   
     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;  
     $token=~tr/a-z/A-Z/;  
   
     my %infohash=('resource.0.outtoken' => $token,  
                   'resource.0.checkouttime' => $now,  
                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     } else {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }      
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  
                          &escape('Checkout '.$infostr.' - '.  
                                                  $token)) ne 'ok') {  
  return '';  
     } else {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }  
     return $token;  
 }  
   
 # ------------------------------------------------------------ Check in an item  
   
 sub checkin {  
     my $token=shift;  
     my $now=time;  
     my ($ta,$tb,$lonhost)=split(/\*/,$token);  
     $lonhost=~tr/A-Z/a-z/;  
     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;  
     $dtoken=~s/\W/\_/g;  
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=  
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));  
   
     unless (($tuname) && ($tudom)) {  
         &logthis('Check in '.$token.' ('.$dtoken.') failed');  
         return '';  
     }  
       
     unless (&allowed('mgr',$tcrsid)) {  
         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.  
                  $env{'user.name'}.' - '.$env{'user.domain'});  
         return '';  
     }  
   
     my %infohash=('resource.0.intoken' => $token,  
                   'resource.0.checkintime' => $now,  
                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     }      
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  
                          &escape('Checkin - '.$token)) ne 'ok') {  
  return '';  
     }  
   
     return ($symb,$tuname,$tudom,$tcrsid);      
 }  
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 4338  sub set_userprivs { Line 4192  sub set_userprivs {
     my $adv=0;      my $adv=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         my @groupkeys;          my @groupkeys; 
         foreach my $role (keys(%{$allroles})) {          foreach my $role (keys(%{$allroles})) {
             push(@groupkeys,$role);              push(@groupkeys,$role);
         }          }
Line 4414  sub role_status { Line 4268  sub role_status {
                             my %userroles = (                              my %userroles = (
                                 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend                                  'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
                             );                              );
                             @rolecodes = ('cm');                              @rolecodes = ('cm'); 
                             my $spec=$$role.'.'.$$where;                              my $spec=$$role.'.'.$$where;
                             my ($tdummy,$tdomain,$trest)=split(/\//,$$where);                              my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
                             if ($$role =~ /^cr\//) {                              if ($$role =~ /^cr\//) {
Line 4431  sub role_status { Line 4285  sub role_status {
                                 my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);                                  my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
                                 if (keys(%course_roles) > 0) {                                  if (keys(%course_roles) > 0) {
                                     my ($tnum) = ($trest =~ /^($match_courseid)/);                                      my ($tnum) = ($trest =~ /^($match_courseid)/);
                                     if ($tdomain ne '' && $tnum ne '') {                                      if ($tdomain ne '' && $tnum ne '') { 
                                         foreach my $key (keys(%course_roles)) {                                          foreach my $key (keys(%course_roles)) {
                                             if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {                                              if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {
                                                 my $crsrole = $1;                                                  my $crsrole = $1;
Line 5116  sub is_portfolio_file { Line 4970  sub is_portfolio_file {
 }  }
   
 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);
     if ($context eq '') {      if ($context eq '') {
         $context = 'tools';          $context = 'tools';
Line 5263  sub is_advanced_user { Line 5117  sub is_advanced_user {
     my ($udom,$uname) = @_;      my ($udom,$uname) = @_;
     if ($udom ne '' && $uname ne '') {      if ($udom ne '' && $uname ne '') {
         if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {          if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
             return $env{'user.adv'};              return $env{'user.adv'};  
         }          }
     }      }
     my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);      my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
Line 5781  sub allowed { Line 5635  sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/\Q$rolecode\E/) {     =~/\Q$rolecode\E/) {
            if (($priv ne 'pch') && ($priv ne 'plc')) {     if ($priv ne 'pch') { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 5791  sub allowed { Line 5645  sub allowed {
   
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/\Q$unamedom\E/) {     =~/\Q$unamedom\E/) {
            if (($priv ne 'pch') && ($priv ne 'plc')) {     if ($priv ne 'pch') { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
  'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
  $env{'request.course.id'});   $env{'request.course.id'});
Line 5805  sub allowed { Line 5659  sub allowed {
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$env{'request.role'}))[0];         my $rolecode=(split(/\./,$env{'request.role'}))[0];
        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {         if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
            if (($priv ne 'pch') && ($priv ne 'plc')) {     if ($priv ne 'pch') { 
        &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
    }     }
Line 6158  sub auto_get_sections { Line 6012  sub auto_get_sections {
 }  }
   
 sub auto_new_course {  sub auto_new_course {
     my ($cnum,$cdom,$inst_course_id,$owner,$coowners) = @_;      my ($cnum,$cdom,$inst_course_id,$owner) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.&escape($owner).':'.$cdom.':'.&escape($coowners),$homeserver));      my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
   
Line 6906  sub modifyuser { Line 6760  sub modifyuser {
     }      }
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.               $umode.', '.$first.', '.$middle.', '.
              $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.       $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                      ' desiredhome not specified').                                        ' desiredhome not specified'). 
              ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
Line 7052  sub modifyuser { Line 6906  sub modifyuser {
         return 'ok';          return 'ok';
     }      }
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') {      if ($reply ne 'ok') { 
         return 'error: '.$reply;          return 'error: '.$reply;
     }      }
     if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {      if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
Line 7377  sub store_userdata { Line 7231  sub store_userdata {
                     $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';                      $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                 }                  }
                 $namevalue=~s/\&$//;                  $namevalue=~s/\&$//;
                 $result =  &reply("store:$udom:$uname:$namespace:$datakey:".                  $result =  &reply("store:$env{'user.domain'}:$env{'user.name'}:".
                                   $namevalue,$uhome);                                    "$namespace:$datakey:$namevalue",$uhome);
             }              }
         } else {          } else {
             $result = 'error: data to store was not a hash reference';               $result = 'error: data to store was not a hash reference'; 
Line 7431  sub diskusage { Line 7285  sub diskusage {
 }  }
   
 sub is_locked {  sub is_locked {
     my ($file_name, $domain, $user, $which) = @_;      my ($file_name, $domain, $user) = @_;
     my @check;      my @check;
     my $is_locked;      my $is_locked;
     push(@check,$file_name);      push (@check,$file_name);
     my %locked = &get('file_permissions',\@check,      my %locked = &get('file_permissions',\@check,
       $env{'user.domain'},$env{'user.name'});        $env{'user.domain'},$env{'user.name'});
     my ($tmp)=keys(%locked);      my ($tmp)=keys(%locked);
Line 7443  sub is_locked { Line 7297  sub is_locked {
     if (ref($locked{$file_name}) eq 'ARRAY') {      if (ref($locked{$file_name}) eq 'ARRAY') {
         $is_locked = 'false';          $is_locked = 'false';
         foreach my $entry (@{$locked{$file_name}}) {          foreach my $entry (@{$locked{$file_name}}) {
            if (ref($entry) eq 'ARRAY') {             if (ref($entry) eq 'ARRAY') { 
                $is_locked = 'true';                 $is_locked = 'true';
                if (ref($which) eq 'ARRAY') {                 last;
                    push(@{$which},$entry);  
                } else {  
                    last;  
                }  
            }             }
        }         }
     } else {      } else {
Line 8598  sub add_prefix_and_part { Line 8448  sub add_prefix_and_part {
 # ---------------------------------------------------------------- Get metadata  # ---------------------------------------------------------------- Get metadata
   
 my %metaentry;  my %metaentry;
   my %importedpartids;
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 8605  sub metadata { Line 8456  sub metadata {
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^\*uploaded\/.+\.sequence$/) ) {
  return undef;   return undef;
     }      }
     if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})       if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) 
Line 8624  sub metadata { Line 8475  sub metadata {
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
     {      {
   # Imported parts would go here
           my %importedids=();
           my @origfileimportpartids=();
           my $importedparts=0;
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
Line 8647  sub metadata { Line 8502  sub metadata {
  &Apache::lonnet::ssi_body($which,   &Apache::lonnet::ssi_body($which,
   ('grade_target' => 'meta'));    ('grade_target' => 'meta'));
     $cachetime = 1; # only want this cached in the child not long term      $cachetime = 1; # only want this cached in the child not long term
  } elsif (($uri !~ m -^(editupload)/-) &&    } elsif ($uri !~ m -^(editupload)/-) {
                  ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) {  
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
Line 8708  sub metadata { Line 8562  sub metadata {
 # This is not a package - some other kind of start tag  # This is not a package - some other kind of start tag
 #  #
     my $entry=$token->[1];      my $entry=$token->[1];
     my $unikey;      my $unikey='';
     if ($entry eq 'import') {  
  $unikey='';  
     } else {  
  $unikey=$entry;  
     }  
     $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});  
   
     if (defined($token->[2]->{'id'})) {   
  $unikey.='_'.$token->[2]->{'id'};   
     }  
   
     if ($entry eq 'import') {      if ($entry eq 'import') {
 #  #
 # Importing a library here  # Importing a library here
 #  #
                           my $location=$parser->get_text('/import');
                           my $dir=$filename;
                           $dir=~s|[^/]*$||;
                           $location=&filelocation($dir,$location);
                          
                           my $importmode=$token->[2]->{'importmode'};
                           if ($importmode eq 'problem') {
   # Import as problem/response
                              $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                           } elsif ($importmode eq 'part') {
   # Import as part(s)
                              $importedparts=1;
   # We need to get the original file and the imported file to get the part order correct
   # Good news: we do not need to worry about nested libraries, since parts cannot be nested
   # Load and inspect original file
                              if ($#origfileimportpartids<0) {
                                 undef(%importedpartids);
                                 my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                 my $origfile=&getfile($origfilelocation);
                                 @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                              }
   
   # Load and inspect imported file
                              my $impfile=&getfile($location);
                              my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                              if ($#impfilepartids>=0) {
   # This problem had parts
                                  $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
                              } else {
   # Importing by turning a single problem into a problem part
   # It gets the import-tags ID as part-ID
                                  $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
                                  $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
                              }
                           } else {
   # Normal import
                              $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                              if (defined($token->[2]->{'id'})) {
                                 $unikey.='_'.$token->[2]->{'id'};
                              }
                           }
   
  if ($depthcount<20) {   if ($depthcount<20) {
     my $location=$parser->get_text('/import');  
     my $dir=$filename;  
     $dir=~s|[^/]*$||;  
     $location=&filelocation($dir,$location);  
     my $metadata =       my $metadata = 
  &metadata($uri,'keys', $location,$unikey,   &metadata($uri,'keys', $location,$unikey,
   $depthcount+1);    $depthcount+1);
Line 8736  sub metadata { Line 8618  sub metadata {
  $metaentry{':'.$meta}=$metaentry{':'.$meta};   $metaentry{':'.$meta}=$metaentry{':'.$meta};
  $metathesekeys{$meta}=1;   $metathesekeys{$meta}=1;
     }      }
  }  
     } else {                           }
       } else {
   #
   # Not importing, some other kind of non-package, non-library start tag
   # 
                           $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
                           if (defined($token->[2]->{'id'})) {
                               $unikey.='_'.$token->[2]->{'id'};
                           }
  if (defined($token->[2]->{'name'})) {    if (defined($token->[2]->{'name'})) { 
     $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
  }   }
Line 8811  sub metadata { Line 8701  sub metadata {
     grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));      grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  $metaentry{':packages'} = join(',',@uniq_packages);   $metaentry{':packages'} = join(',',@uniq_packages);
   
           if ($importedparts) {
   # We had imported parts and need to rebuild partorder
              $metaentry{':partorder'}='';
              $metathesekeys{'partorder'}=1;
              for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
                  if ($origfileimportpartids[$index] eq 'part') {
   # original part, part of the problem
                     $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
                  } else {
   # we have imported parts at this position
                     $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
                  }
              }
              $metaentry{':partorder'}=~s/^\,//;
           }
   
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
Line 8996  sub symbverify { Line 8902  sub symbverify {
         }          }
         my $ids=$bighash{'ids_'.&clutter($thisurl)};          my $ids=$bighash{'ids_'.&clutter($thisurl)};
         unless ($ids) {           unless ($ids) { 
            my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;             $ids=$bighash{'ids_/'.$thisurl};
            $ids=$bighash{$idkey};  
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
Line 9010  sub symbverify { Line 8915  sub symbverify {
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {      eq $symb) { 
    if (($env{'request.role.adv'}) ||     if (($env{'request.role.adv'}) ||
        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||         $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
        ($thisurl eq '/adm/navmaps')) {  
        $okay=1;          $okay=1; 
    }     }
        }         }
Line 10090  sub get_dns { Line 9994  sub get_dns {
     my $loaded;      my $loaded;
     my %name_to_host;      my %name_to_host;
     my %internetdom;      my %internetdom;
     my %LC_dns_serv;  
   
     sub parse_hosts_tab {      sub parse_hosts_tab {
  my ($file) = @_;   my ($file) = @_;
  foreach my $configline (@$file) {   foreach my $configline (@$file) {
     next if ($configline =~ /^(\#|\s*$ )/x);      next if ($configline =~ /^(\#|\s*$ )/x);
             chomp($configline);      next if ($configline =~ /^\^/);
             if ($configline =~ /^\^/) {      chomp($configline);
                 if ($configline =~ /^\^([\w.\-]+)/) {  
                     $LC_dns_serv{$1} = 1;  
                 }  
                 next;  
             }  
     my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);      my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     if ($id && $domain && $role && $name) {      if ($id && $domain && $role && $name) {
Line 10184  sub get_dns { Line 10082  sub get_dns {
     }      }
   
     sub unique_library {      sub unique_library {
         #2x reverse removes all hostnames that appear more than once   #2x reverse removes all hostnames that appear more than once
         my %unique = reverse &all_library();          my %unique = reverse &all_library();
         return reverse %unique;          return reverse %unique;
     }      }
Line 10214  sub get_dns { Line 10112  sub get_dns {
   
     sub get_unique_servers {      sub get_unique_servers {
         my %unique = reverse &get_servers(@_);          my %unique = reverse &get_servers(@_);
         return reverse %unique;   return reverse %unique;
     }      }
   
     sub host_domain {      sub host_domain {
Line 10238  sub get_dns { Line 10136  sub get_dns {
         my ($lonid) = @_;          my ($lonid) = @_;
         return $internetdom{$lonid};          return $internetdom{$lonid};
     }      }
   
     sub is_LC_dns {  
         &load_hosts_tab() if (!$loaded);  
   
         my ($hostname) = @_;  
         return exists($LC_dns_serv{$hostname});  
     }  
   
 }  }
   
 {   { 
Line 10758  $checkdefauth is optional (value is 1 if Line 10648  $checkdefauth is optional (value is 1 if
    authenticate user using default authentication method, and allow     authenticate user using default authentication method, and allow
    account creation if username does not have account in the domain).     account creation if username does not have account in the domain).
 $clientcancheckhost is optional (value is 1 if checking whether the  $clientcancheckhost is optional (value is 1 if checking whether the
    server can host will occur on the client side in lonauth.pm).     server can host will occur on the client side in lonauth.pm).   
   
 =item *  =item *
 X<homeserver()>  X<homeserver()>
Line 11508  userfileupload(): main rotine for puttin Line 11398  userfileupload(): main rotine for puttin
            the filename is in $env{'form.'.$formname.'.filename'} and the             the filename is in $env{'form.'.$formname.'.filename'} and the
            contents of the file is located in $env{'form.'.$formname}             contents of the file is located in $env{'form.'.$formname}
  context - if coursedoc, store the file in the course of the active role   context - if coursedoc, store the file in the course of the active role
              of the current user;               of the current user; 
            if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp             if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp
            if 'canceloverwrite': delete file in tmp/overwrites directory             if 'canceloverwrite': delete file in tmp/overwrites directory
  subdir - required - subdirectory to put the file in under ../userfiles/   subdir - required - subdirectory to put the file in under ../userfiles/
Line 11548  userspace, probably shouldn't be called Line 11438  userspace, probably shouldn't be called
   resizeheight: height to be used to resize image using resizeImage from ImageMagick    resizeheight: height to be used to resize image using resizeImage from ImageMagick
   context: if 'overwrite', will move the uploaded file from its temporary location to    context: if 'overwrite', will move the uploaded file from its temporary location to
             userfiles to facilitate overwriting a previously uploaded file with same name.              userfiles to facilitate overwriting a previously uploaded file with same name.
   mimetype: reference to scalar to accommodate mime type determined  
             from File::MMagic if $parser = parse.  
   
  returns either the url of the uploaded file (/uploaded/....) if successful   returns either the url of the uploaded file (/uploaded/....) if successful
  and /adm/notfound.html if unsuccessful (or an error message if context    and /adm/notfound.html if unsuccessful (or an error message if context 
  was 'overwrite').   was 'overwrite').
    
   
 =item *  =item *
   
Removed from v.1.1056.4.28  
changed lines
  Added in v.1.1093

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