[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.762 and 1.785

version 1.762, 2006/07/19 19:44:52 version 1.785, 2006/09/28 20:03:55
Line 292  sub error { Line 292  sub error {
     return undef;      return undef;
 }  }
   
 # ------------------------------------------- Transfer profile into environment  sub convert_and_load_session_env {
       my ($lonidsdir,$handle)=@_;
       my @profile;
       {
    open(my $idf,"$lonidsdir/$handle.id");
    flock($idf,LOCK_SH);
    @profile=<$idf>;
    close($idf);
       }
       my %temp_env;
       foreach my $line (@profile) {
    chomp($line);
    my ($envname,$envvalue)=split(/=/,$line,2);
    $temp_env{&unescape($envname)} = &unescape($envvalue);
       }
       unlink("$lonidsdir/$handle.id");
       if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
       0640)) {
    %disk_env = %temp_env;
    @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
    untie(%disk_env);
       }
   }
   
   # ------------------------------------------- Transfer profile into environment
   my $env_loaded;
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
       if ($env_loaded) { return; } 
   
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
     if (!defined($lonidsdir)) {      if (!defined($lonidsdir)) {
  $lonidsdir = $perlvar{'lonIDsDir'};   $lonidsdir = $perlvar{'lonIDsDir'};
Line 303  sub transfer_profile_to_env { Line 329  sub transfer_profile_to_env {
         ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );          ($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
     }      }
   
     my @profile;      my %remove;
     {      if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
  open(my $idf,"$lonidsdir/$handle.id");      0640)) {
  flock($idf,LOCK_SH);   @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
  @profile=<$idf>;   untie(%disk_env);
  close($idf);      } else {
    &convert_and_load_session_env($lonidsdir,$handle);
     }      }
     my $envi;  
     my %Remove;      while ( my $envname = each(%env) ) {
     for ($envi=0;$envi<=$#profile;$envi++) {  
  chomp($profile[$envi]);  
  my ($envname,$envvalue)=split(/=/,$profile[$envi],2);  
  $envname=&unescape($envname);  
  $envvalue=&unescape($envvalue);  
  $env{$envname} = $envvalue;  
         if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {          if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
             if ($time < time-300) {              if ($time < time-300) {
                 $Remove{$key}++;                  $remove{$key}++;
             }              }
         }          }
     }      }
   
     $env{'user.environment'} = "$lonidsdir/$handle.id";      $env{'user.environment'} = "$lonidsdir/$handle.id";
     foreach my $expired_key (keys(%Remove)) {      $env_loaded=1;
       foreach my $expired_key (keys(%remove)) {
         &delenv($expired_key);          &delenv($expired_key);
     }      }
 }  }
Line 344  sub appenv { Line 367  sub appenv {
             $env{$key}=$newenv{$key};              $env{$key}=$newenv{$key};
         }          }
     }      }
       if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
     my $lockfh;      0640)) {
     unless (open($lockfh,"$env{'user.environment'}")) {   while (my ($key,$value) = each(%newenv)) {
  return 'error: '.$!;      $disk_env{$key} = $value;
     }  
     unless (flock($lockfh,LOCK_EX)) {  
          &logthis("<font color=\"blue\">WARNING: ".  
                   'Could not obtain exclusive lock in appenv: '.$!);  
          close($lockfh);  
          return 'error: '.$!;  
     }  
   
     my @oldenv;  
     {  
  my $fh;  
  unless (open($fh,"$env{'user.environment'}")) {  
     return 'error: '.$!;  
  }  
  @oldenv=<$fh>;  
  close($fh);  
     }  
     for (my $i=0; $i<=$#oldenv; $i++) {  
         chomp($oldenv[$i]);  
         if ($oldenv[$i] ne '') {  
     my ($name,$value)=split(/=/,$oldenv[$i],2);  
     $name=&unescape($name);  
     $value=&unescape($value);  
     unless (defined($newenv{$name})) {  
  $newenv{$name}=$value;  
     }  
         }  
     }  
     {  
  my $fh;  
  unless (open($fh,">$env{'user.environment'}")) {  
     return 'error';  
  }  
  my $newname;  
  foreach $newname (keys %newenv) {  
     print $fh &escape($newname).'='.&escape($newenv{$newname})."\n";  
  }   }
  close($fh);   untie(%disk_env);
     }      }
   
     close($lockfh);  
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
Line 400  sub delenv { Line 385  sub delenv {
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
     my @oldenv;      if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
     {      0640)) {
  my $fh;   foreach my $key (keys(%disk_env)) {
  unless (open($fh,"$env{'user.environment'}")) {      if ($key=~/^$delthis/) { 
     return 'error';  
  }  
  unless (flock($fh,LOCK_SH)) {  
     &logthis("<font color=\"blue\">WARNING: ".  
      'Could not obtain shared lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  @oldenv=<$fh>;  
  close($fh);  
     }  
     {  
  my $fh;  
  unless (open($fh,">$env{'user.environment'}")) {  
     return 'error';  
  }  
  unless (flock($fh,LOCK_EX)) {  
     &logthis("<font color=\"blue\">WARNING: ".  
      'Could not obtain exclusive lock in delenv: '.$!);  
     close($fh);  
     return 'error: '.$!;  
  }  
  foreach my $cur_key (@oldenv) {  
     my $unescaped_cur_key = &unescape($cur_key);  
     if ($unescaped_cur_key=~/^$delthis/) {   
                 my ($key) = split('=',$cur_key,2);  
  $key = &unescape($key);  
                 delete($env{$key});                  delete($env{$key});
             } else {                  delete($disk_env{$key});
                 print $fh $cur_key;   
             }              }
  }   }
  close($fh);   untie(%disk_env);
     }      }
     return 'ok';      return 'ok';
 }  }
Line 493  sub overloaderror { Line 450  sub overloaderror {
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name) = @_;      my ($loadpercent,$userloadpercent,$want_server_name) = @_;
     my $tryserver;      my $spare_server;
     my $spareserver='';  
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowestserver=$loadpercent > $userloadpercent?      my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
              $loadpercent :  $userloadpercent;                                                       :  $userloadpercent;
     foreach $tryserver (keys(%spareid)) {      
  my $loadans=&reply('load',$tryserver);      foreach my $try_server (@{ $spareid{'primary'} }) {
  my $userloadans=&reply('userload',$tryserver);   ($spare_server, $lowest_load) =
  if ($loadans !~ /\d/ && $userloadans !~ /\d/) {      &compare_server_load($try_server, $spare_server, $lowest_load);
     next; #didn't get a number from the server      }
  }  
  my $answer;      my $found_server = ($spare_server ne '' && $lowest_load < 100);
  if ($loadans =~ /\d/) {  
     if ($userloadans =~ /\d/) {      if (!$found_server) {
  #both are numbers, pick the bigger one   foreach my $try_server (@{ $spareid{'default'} }) {
  $answer=$loadans > $userloadans?      ($spare_server, $lowest_load) =
     $loadans :  $userloadans;   &compare_server_load($try_server, $spare_server, $lowest_load);
     } else {  
  $answer = $loadans;  
     }  
  } else {  
     $answer = $userloadans;  
  }  
  if (($answer =~ /\d/) && ($answer<$lowestserver)) {  
     if ($want_server_name) {  
  $spareserver=$tryserver;  
     } else {  
  $spareserver="http://$hostname{$tryserver}";  
     }  
     $lowestserver=$answer;  
  }   }
     }      }
     return $spareserver;  
       if (!$want_server_name) {
    $spare_server="http://$hostname{$spare_server}";
       }
       return $spare_server;
 }  }
   
   sub compare_server_load {
       my ($try_server, $spare_server, $lowest_load) = @_;
   
       my $loadans     = &reply('load',    $try_server);
       my $userloadans = &reply('userload',$try_server);
   
       if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
    next; #didn't get a number from the server
       }
   
       my $load;
       if ($loadans =~ /\d/) {
    if ($userloadans =~ /\d/) {
       #both are numbers, pick the bigger one
       $load = ($loadans > $userloadans) ? $loadans 
                                 : $userloadans;
    } else {
       $load = $loadans;
    }
       } else {
    $load = $userloadans;
       }
   
       if (($load =~ /\d/) && ($load < $lowest_load)) {
    $spare_server = $try_server;
    $lowest_load  = $load;
       }
       return ($spare_server,$lowest_load);
   }
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 891  sub save_cache { Line 867  sub save_cache {
     &purge_remembered();      &purge_remembered();
     #&Apache::loncommon::validate_page();      #&Apache::loncommon::validate_page();
     undef(%env);      undef(%env);
       undef($env_loaded);
 }  }
   
 my $to_remember=-1;  my $to_remember=-1;
Line 1176  sub ssi_body { Line 1153  sub ssi_body {
     }      }
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink,%form));                                       &ssi($filelink,%form));
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;      $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;
     return $output;      return $output;
Line 1184  sub ssi_body { Line 1161  sub ssi_body {
   
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
   sub absolute_url {
       my ($host_name) = @_;
       my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
       if ($host_name eq '') {
    $host_name = $ENV{'SERVER_NAME'};
       }
       return $protocol.$host_name;
   }
   
   sub absolute_url {
       my ($host_name) = @_;
       my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
       if ($host_name eq '') {
    $host_name = $ENV{'SERVER_NAME'};
       }
       return $protocol.$host_name;
   }
   
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
Line 1195  sub ssi { Line 1190  sub ssi {
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
   
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('POST',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));
     } else {      } else {
       $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
Line 2845  sub set_userprivs { Line 2840  sub set_userprivs {
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         foreach my $role (keys %{$allroles}) {          foreach my $role (keys %{$allroles}) {
             my ($trole,$area,$sec,$extendedarea);              my ($trole,$area,$sec,$extendedarea);
             if ($role =~ m|^(\w+)\.(/\w+/\w+)(/?\w*)|) {              if ($role =~ m-^(\w+|cr/\w+/\w+/\w+)\.(/\w+/\w+)(/?\w*)-) {
                 $trole = $1;                  $trole = $1;
                 $area = $2;                  $area = $2;
                 $sec = $3;                  $sec = $3;
Line 3217  sub tmpdel { Line 3212  sub tmpdel {
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
   # -------------------------------------------------- portfolio access checking
   
   sub portfolio_access {
       my ($requrl) = @_;
       my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
       my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
       if ($result eq 'ok') {
          return 'F';
       } elsif ($result =~ /^[^:]+:guest_/) {
          return 'A';
       }
       return '';
   }
   
   sub get_portfolio_access {
       my ($udom,$unum,$file_name,$group,$access_hash) = @_;
   
       if (!ref($access_hash)) {
    my $current_perms = &get_portfile_permissions($udom,$unum);
    my %access_controls = &get_access_controls($current_perms,$group,
      $file_name);
    $access_hash = $access_controls{$file_name};
       }
   
       my ($public,$guest,@domains,@users,@courses,@groups);
       my $now = time;
       if (ref($access_hash) eq 'HASH') {
           foreach my $key (keys(%{$access_hash})) {
               my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
               if ($start > $now) {
                   next;
               }
               if ($end && $end<$now) {
                   next;
               }
               if ($scope eq 'public') {
                   $public = $key;
                   last;
               } elsif ($scope eq 'guest') {
                   $guest = $key;
               } elsif ($scope eq 'domains') {
                   push(@domains,$key);
               } elsif ($scope eq 'users') {
                   push(@users,$key);
               } elsif ($scope eq 'course') {
                   push(@courses,$key);
               } elsif ($scope eq 'group') {
                   push(@groups,$key);
               }
           }
           if ($public) {
               return 'ok';
           }
           if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
               if ($guest) {
                   return $guest;
               }
           } else {
               if (@domains > 0) {
                   foreach my $domkey (@domains) {
                       if (ref($access_hash->{$domkey}{'dom'}) eq 'ARRAY') {
                           if (grep(/^\Q$env{'user.domain'}\E$/,@{$access_hash->{$domkey}{'dom'}})) {
                               return 'ok';
                           }
                       }
                   }
               }
               if (@users > 0) {
                   foreach my $userkey (@users) {
                       if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {
                           return 'ok';
                       }
                   }
               }
               my %roleshash;
               my @courses_and_groups = @courses;
               push(@courses_and_groups,@groups); 
               if (@courses_and_groups > 0) {
                   my (%allgroups,%allroles); 
                   my ($start,$end,$role,$sec,$group);
                   foreach my $envkey (%env) {
                       if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./([^/]+)/([^/]+)/?([^/]*)$-) {
                           my $cid = $2.'_'.$3; 
                           if ($1 eq 'gr') {
                               $group = $4;
                               $allgroups{$cid}{$group} = $env{$envkey};
                           } else {
                               if ($4 eq '') {
                                   $sec = 'none';
                               } else {
                                   $sec = $4;
                               }
                               $allroles{$cid}{$1}{$sec} = $env{$envkey};
                           }
                       } elsif ($envkey =~ m-^user\.role\./cr/(\w+/\w+/\w*)./([^/]+)/([^/]+)/?([^/]*)$-) {
                           my $cid = $2.'_'.$3;
                           if ($4 eq '') {
                               $sec = 'none';
                           } else {
                               $sec = $4;
                           }
                           $allroles{$cid}{$1}{$sec} = $env{$envkey};
                       }
                   }
                   if (keys(%allroles) == 0) {
                       return;
                   }
                   foreach my $key (@courses_and_groups) {
                       my %content = %{$$access_hash{$key}};
                       my $cnum = $content{'number'};
                       my $cdom = $content{'domain'};
                       my $cid = $cdom.'_'.$cnum;
                       if (!exists($allroles{$cid})) {
                           next;
                       }    
                       foreach my $role_id (keys(%{$content{'roles'}})) {
                           my @sections = @{$content{'roles'}{$role_id}{'section'}};
                           my @groups = @{$content{'roles'}{$role_id}{'group'}};
                           my @status = @{$content{'roles'}{$role_id}{'access'}};
                           my @roles = @{$content{'roles'}{$role_id}{'role'}};
                           foreach my $role (keys(%{$allroles{$cid}})) {
                               if ((grep/^all$/,@roles) || (grep/^\Q$role\E$/,@roles)) {
                                   foreach my $sec (keys(%{$allroles{$cid}{$role}})) {
                                       if (&course_group_datechecker($allroles{$cid}{$role}{$sec},$now,\@status) eq 'ok') {
                                           if (grep/^all$/,@sections) {
                                               return 'ok';
                                           } else {
                                               if (grep/^$sec$/,@sections) {
                                                   return 'ok';
                                               }
                                           }
                                       }
                                   }
                                   if (keys(%{$allgroups{$cid}}) == 0) {
                                       if (grep/^none$/,@groups) {
                                           return 'ok';
                                       }
                                   } else {
                                       if (grep/^all$/,@groups) {
                                           return 'ok';
                                       } 
                                       foreach my $group (keys(%{$allgroups{$cid}})) {
                                           if (grep/^$group$/,@groups) {
                                               return 'ok';
                                           }
                                       }
                                   } 
                               }
                           }
                       }
                   }
               }
               if ($guest) {
                   return $guest;
               }
           }
       }
       return;
   }
   
   sub course_group_datechecker {
       my ($dates,$now,$status) = @_;
       my ($start,$end) = split(/\./,$dates);
       if (!$start && !$end) {
           return 'ok';
       }
       if (grep/^active$/,@{$status}) {
           if (((!$start) || ($start && $start <= $now)) && ((!$end) || ($end && $end >= $now))) {
               return 'ok';
           }
       }
       if (grep/^previous$/,@{$status}) {
           if ($end > $now ) {
               return 'ok';
           }
       }
       if (grep/^future$/,@{$status}) {
           if ($start > $now) {
               return 'ok';
           }
       }
       return; 
   }
   
   sub parse_portfolio_url {
       my ($url) = @_;
   
       my ($type,$udom,$unum,$group,$file_name);
       
       if ($url =~  m-^/*uploaded/([^/]+)/([^/]+)/portfolio(/.+)$-) {
    $type = 1;
           $udom = $1;
           $unum = $2;
           $file_name = $3;
       } elsif ($url =~ m-^/*uploaded/([^/]+)/([^/]+)/groups/([^/]+)/portfolio/(.+)$-) {
    $type = 2;
           $udom = $1;
           $unum = $2;
           $group = $3;
           $file_name = $3.'/'.$4;
       }
       if (wantarray) {
    return ($type,$udom,$unum,$file_name,$group);
       }
       return $type;
   }
   
   sub is_portfolio_url {
       my ($url) = @_;
       return scalar(&parse_portfolio_url($url));
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 3262  sub allowed { Line 3469  sub allowed {
           
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) 
  || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {   || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
    && ($priv eq 'bre')) {
  return 'F';   return 'F';
     }      }
   
Line 3388  sub allowed { Line 3596  sub allowed {
         }          }
     }      }
   
       if ($priv eq 'bre'
    && $thisallowed ne 'F' 
    && $thisallowed ne '2'
    && &is_portfolio_url($uri)) {
    $thisallowed = &portfolio_access($uri);
       }
       
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
Line 3538  sub allowed { Line 3753  sub allowed {
 #  #
   
     unless ($env{'request.course.id'}) {      unless ($env{'request.course.id'}) {
        return '1';   if ($thisallowed eq 'A') {
       return 'A';
    } else {
       return '1';
    }
     }      }
   
 #  #
Line 3601  sub allowed { Line 3820  sub allowed {
       }        }
    }     }
   
       if ($thisallowed eq 'A') {
    return 'A';
       }
    return 'F';     return 'F';
 }  }
   
Line 3847  sub auto_run { Line 4069  sub auto_run {
     my $response = &reply('autorun:'.$cdom,$homeserver);      my $response = &reply('autorun:'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
                                                                                      
 sub auto_get_sections {  sub auto_get_sections {
     my ($cnum,$cdom,$inst_coursecode) = @_;      my ($cnum,$cdom,$inst_coursecode) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
Line 3858  sub auto_get_sections { Line 4080  sub auto_get_sections {
     }      }
     return @secs;      return @secs;
 }  }
                                                                                      
 sub auto_new_course {  sub auto_new_course {
     my ($cnum,$cdom,$inst_course_id,$owner) = @_;      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.':'.$owner.':'.$cdom,$homeserver));      my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
                                                                                      
 sub auto_validate_courseID {  sub auto_validate_courseID {
     my ($cnum,$cdom,$inst_course_id) = @_;      my ($cnum,$cdom,$inst_course_id) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));      my $response=&unescape(&reply('autovalidatecourse:'.$inst_course_id.':'.$cdom,$homeserver));
     return $response;      return $response;
 }  }
                                                                                      
 sub auto_create_password {  sub auto_create_password {
     my ($cnum,$cdom,$authparam) = @_;      my ($cnum,$cdom,$authparam) = @_;
     my $homeserver = &homeserver($cnum,$cdom);       my $homeserver = &homeserver($cnum,$cdom); 
Line 3966  sub auto_photoupdate { Line 4188  sub auto_photoupdate {
 sub auto_instcode_format {  sub auto_instcode_format {
     my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;      my ($caller,$codedom,$instcodes,$codes,$codetitles,$cat_titles,$cat_order) = @_;
     my $courses = '';      my $courses = '';
     my $homeserver;      my @homeservers;
     if ($caller eq 'global') {      if ($caller eq 'global') {
         foreach my $tryserver (keys %libserv) {          foreach my $tryserver (keys %libserv) {
             if ($hostdom{$tryserver} eq $codedom) {              if ($hostdom{$tryserver} eq $codedom) {
                 $homeserver = $tryserver;                  if (!grep/^\Q$tryserver\E$/,@homeservers) {
                 last;                      push(@homeservers,$tryserver);
                   }
             }              }
         }          }
         if (($env{'user.name'}) && ($env{'user.domain'} eq $codedom)) {  
             $homeserver = &homeserver($env{'user.name'},$codedom);  
         }  
     } else {      } else {
         $homeserver = &homeserver($caller,$codedom);          push(@homeservers,&homeserver($caller,$codedom));
     }      }
     foreach (keys %{$instcodes}) {      foreach (keys %{$instcodes}) {
         $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';          $courses .= &escape($_).'='.&escape($$instcodes{$_}).'&';
     }      }
     chop($courses);      chop($courses);
     my $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$homeserver);      my $ok_response = 0;
     unless ($response =~ /(con_lost|error|no_such_host|refused)/) {      my $response;
         my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = split/:/,$response;      while (@homeservers > 0 && $ok_response == 0) {
         %{$codes} = &str2hash($codes_str);          my $server = shift(@homeservers); 
         @{$codetitles} = &str2array($codetitles_str);          $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
         %{$cat_titles} = &str2hash($cat_titles_str);          if ($response !~ /(con_lost|error|no_such_host|refused)/) {
         %{$cat_order} = &str2hash($cat_order_str);              my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
                                                               split/:/,$response;
               %{$codes} = (%{$codes},&str2hash($codes_str));
               push(@{$codetitles},&str2array($codetitles_str));
               %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
               %{$cat_order} = (%{$cat_order},&str2hash($cat_order_str));
               $ok_response = 1;
           }
       }
       if ($ok_response) {
         return 'ok';          return 'ok';
       } else {
           return $response;
     }      }
   }
   
   sub auto_validate_class_sec {
       my ($cdom,$cnum,$owner,$inst_class) = @_;
       my $homeserver = &homeserver($cnum,$cdom);
       my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
                           &escape($owner).':'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
   
Line 4688  sub get_portfile_permissions { Line 4926  sub get_portfile_permissions {
   
 sub get_access_controls {  sub get_access_controls {
     my ($current_permissions,$group,$file) = @_;      my ($current_permissions,$group,$file) = @_;
     my %access;       my %access;
       my $real_file = $file;
       $file =~ s/\.meta$//;
     if (defined($file)) {      if (defined($file)) {
         if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {          if (ref($$current_permissions{$file."\0".'accesscontrol'}) eq 'HASH') {
             foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {              foreach my $control (keys(%{$$current_permissions{$file."\0".'accesscontrol'}})) {
                 $access{$file}{$control} = $$current_permissions{$file."\0".$control};                  $access{$real_file}{$control} = $$current_permissions{$file."\0".$control};
             }              }
         }          }
     } else {      } else {
Line 5155  sub devalidatecourseresdata { Line 5395  sub devalidatecourseresdata {
     &devalidate_cache_new('courseres',$hashid);      &devalidate_cache_new('courseres',$hashid);
 }  }
   
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
   
 sub get_courseresdata {  sub get_courseresdata {
Line 5507  sub EXT { Line 5748  sub EXT {
  if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {   if (($uname eq $env{'user.name'})&&($udom eq $env{'user.domain'})) {
     return $env{'environment.'.$spacequalifierrest};      return $env{'environment.'.$spacequalifierrest};
  } else {   } else {
       if ($uname eq 'anonymous' && $udom eq '') {
    return '';
       }
     my %returnhash=&userenvironment($udom,$uname,      my %returnhash=&userenvironment($udom,$uname,
     $spacequalifierrest);      $spacequalifierrest);
     return $returnhash{$spacequalifierrest};      return $returnhash{$spacequalifierrest};
Line 5657  sub metadata { Line 5901  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m -^(uploaded|editupload)/-) {   if ($uri !~ m -^(editupload)/-) {
     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 5876  sub metadata_generate_part0 { Line 6120  sub metadata_generate_part0 {
     }      }
 }  }
   
   # ------------------------------------------------------ Devalidate title cache
   
   sub devalidate_title_cache {
       my ($url)=@_;
       if (!$env{'request.course.id'}) { return; }
       my $symb=&symbread($url);
       if (!$symb) { return; }
       my $key=$env{'request.course.id'}."\0".$symb;
       &devalidate_cache_new('title',$key);
   }
   
 # ------------------------------------------------- Get the title of a resource  # ------------------------------------------------- Get the title of a resource
   
 sub gettitle {  sub gettitle {
Line 6850  BEGIN { Line 7105  BEGIN {
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
     unless ($readit) {      unless ($readit) {
 {  {
     # FIXME: Use LONCAPA::Configuration::read_conf here and omit next block      my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
     open(my $config,"</etc/httpd/conf/loncapa.conf");      %perlvar = (%perlvar,%{$configvars});
   
     while (my $configline=<$config>) {  
         if ($configline=~/\S/ && $configline =~ /^[^\#]*PerlSetVar/) {  
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);  
            chomp($varvalue);  
            $perlvar{$varname}=$varvalue;  
         }  
     }  
     close($config);  
 }  
 {  
     open(my $config,"</etc/httpd/conf/loncapa_apache.conf");  
   
     while (my $configline=<$config>) {  
         if ($configline =~ /^[^\#]*PerlSetVar/) {  
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);  
            chomp($varvalue);  
            $perlvar{$varname}=$varvalue;  
         }  
     }  
     close($config);  
 }  }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
Line 6954  sub get_iphost { Line 7188  sub get_iphost {
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
        chomp($configline);         chomp($configline);
        if ($configline) {         if ($configline) {
           $spareid{$configline}=1;     my ($host,$type) = split(':',$configline,2);
      if (!defined($type) || $type eq '') { $type = 'default' };
      push(@{ $spareid{$type} }, $host);
        }         }
     }      }
     close($config);      close($config);
Line 7282  actions Line 7518  actions
  '': forbidden   '': forbidden
  1: user needs to choose course   1: user needs to choose course
  2: browse allowed   2: browse allowed
    A: passphrase authentication needed
   
 =item *  =item *
   
Line 8009  Internal notes: Line 8246  Internal notes:
     
  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.   Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
   
 parse_access_controls():  
   
 Parses XML of an access control record  
 Args  
 1. Text string (XML) of access comtrol record  
   
 Returns:  
 1. Hash of access control settings.   
   
 modify_access_controls():  modify_access_controls():
   
 Modifies access controls for a portfolio file  Modifies access controls for a portfolio file
Removed from v.1.762  
changed lines
  Added in v.1.785

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