[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.900 and 1.912

version 1.900, 2007/07/26 04:05:43 version 1.912, 2007/09/12 20:29:16
Line 861  sub inst_directory_query { Line 861  sub inst_directory_query {
     my $udom = $srch->{'srchdomain'};      my $udom = $srch->{'srchdomain'};
     my %results;      my %results;
     my $homeserver = &domain($udom,'primary');      my $homeserver = &domain($udom,'primary');
       my $outcome;
     if ($homeserver ne '') {      if ($homeserver ne '') {
         my $response=&reply("instdirsrch:$udom".':'.   my $queryid=&reply("querysend:instdirsearch:".
                             &escape($srch->{'srchby'}).':'.     &escape($srch->{'srchby'}).':'.
                             &escape($srch->{'srchterm'}).':'.     &escape($srch->{'srchterm'}).':'.
                             $srch->{'srchtype'},$homeserver);     &escape($srch->{'srchtype'}),$homeserver);
         if ($response ne 'refused') {   my $host=&hostname($homeserver);
             my @matches = split/&/,$response;   if ($queryid !~/^\Q$host\E\_/) {
             foreach my $match (@matches) {      &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
                 my ($key,$value) = split(/=/,$match);      return;
                 my %userhash = &str2hash(&unescape($value));   }
                 $results{&unescape($key).':'.$udom} = \%userhash;   my $response = &get_query_reply($queryid);
    my $maxtries = 5;
    my $tries = 1;
    while (($response=~/^timeout/) && ($tries < $maxtries)) {
       $response = &get_query_reply($queryid);
       $tries ++;
    }
   
           if (!&error($response) && $response ne 'refused') {
               if ($response eq 'unavailable') {
                   $outcome = $response;
               } else {
                   $outcome = 'ok';
                   my @matches = split(/\n/,$response);
                   foreach my $match (@matches) {
                       my ($key,$value) = split(/=/,$match);
                       $results{&unescape($key).':'.$udom} = &thaw_unescape($value);
                   }
             }              }
         }          }
     }      }
     return %results;      return ($outcome,%results);
 }  }
   
 sub usersearch {  sub usersearch {
Line 888  sub usersearch { Line 906  sub usersearch {
         if (&host_domain($tryserver) eq $dom) {          if (&host_domain($tryserver) eq $dom) {
             my $host=&hostname($tryserver);              my $host=&hostname($tryserver);
             my $queryid=              my $queryid=
                 &reply("querysend:".&escape($query).':'.&escape($dom).':'.                  &reply("querysend:".&escape($query).':'.
                        &escape($srch->{'srchby'}).'%%'.                         &escape($srch->{'srchby'}).':'.
                        &escape($srch->{'srchtype'}).':'.                         &escape($srch->{'srchtype'}).':'.
                        &escape($srch->{'srchterm'}),$tryserver);                         &escape($srch->{'srchterm'}),$tryserver);
             if ($queryid !~/^\Q$host\E\_/) {              if ($queryid !~/^\Q$host\E\_/) {
                 &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);                  &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);
                 return 'error: '.$queryid;                  next;
             }              }
             my $reply = &get_query_reply($queryid);              my $reply = &get_query_reply($queryid);
             my $maxtries = 1;              my $maxtries = 1;
Line 906  sub usersearch { Line 924  sub usersearch {
             if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {              if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
                 &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') -  maxtries: '.$maxtries.' tries: '.$tries);                  &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') -  maxtries: '.$maxtries.' tries: '.$tries);
             } else {              } else {
                 my @matches = split(/&/,$reply);                  my @matches;
                   if ($reply =~ /\n/) {
                       @matches = split(/\n/,$reply);
                   } else {
                       @matches = split(/\&/,$reply);
                   }
                 foreach my $match (@matches) {                  foreach my $match (@matches) {
                     my @items = split(/:/,$match);  
                     my ($uname,$udom,%userhash);                      my ($uname,$udom,%userhash);
                     foreach my $entry (@items) {                      foreach my $entry (split(/:/,$match)) {
                         my ($key,$value) = split(/=/,$entry);                          my ($key,$value) =
                         $key = &unescape($key);                              map {&unescape($_);} split(/=/,$entry);
                         $value = &unescape($value);  
                         $userhash{$key} = $value;                          $userhash{$key} = $value;
                         if ($key eq 'username') {                          if ($key eq 'username') {
                             $uname = $value;                              $uname = $value;
                         } elsif ($key eq 'domain') {                          } elsif ($key eq 'domain') {
                             $udom = $value;                              $udom = $value;
                         }                           }
                     }                      }
                     $results{$uname.':'.$udom} = \%userhash;                      $results{$uname.':'.$udom} = \%userhash;
                 }                  }
Line 929  sub usersearch { Line 950  sub usersearch {
     return %results;      return %results;
 }  }
   
   sub get_instuser {
       my ($udom,$uname,$id) = @_;
       my $homeserver = &domain($udom,'primary');
       my ($outcome,%results);
       if ($homeserver ne '') {
           my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
                              &escape($id).':'.&escape($udom),$homeserver);
           my $host=&hostname($homeserver);
           if ($queryid !~/^\Q$host\E\_/) {
               &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
               return;
           }
           my $response = &get_query_reply($queryid);
           my $maxtries = 5;
           my $tries = 1;
           while (($response=~/^timeout/) && ($tries < $maxtries)) {
               $response = &get_query_reply($queryid);
               $tries ++;
           }
           if (!&error($response) && $response ne 'refused') {
               if ($response eq 'unavailable') {
                   $outcome = $response;
               } else {
                   $outcome = 'ok';
                   my @matches = split(/\n/,$response);
                   foreach my $match (@matches) {
                       my ($key,$value) = split(/=/,$match);
                       $results{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       my %userinfo;
       if (ref($results{$uname}) eq 'HASH') {
           %userinfo = %{$results{$uname}};
       } 
       return ($outcome,%userinfo);
   }
   
   sub inst_rulecheck {
       my ($udom,$uname,$rules) = @_;
       my %returnhash;
       if ($udom ne '') {
           if (ref($rules) eq 'ARRAY') {
               @{$rules} = map {&escape($_);} (@{$rules});
               my $rulestr = join(':',@{$rules});
               my $homeserver=&domain($udom,'primary');
               if (($homeserver ne '') && ($homeserver ne 'no_host')) {
                   my $response=&unescape(&reply('instrulecheck:'.&escape($udom).':'.
                                                 &escape($uname).':'.$rulestr,
                                                 $homeserver));
                   if ($response ne 'refused') {
                       my @pairs=split(/\&/,$response);
                       foreach my $item (@pairs) {
                           my ($key,$value)=split(/=/,$item,2);
                           $key = &unescape($key);
                           next if ($key =~ /^error: 2 /);
                           $returnhash{$key}=&thaw_unescape($value);
                       }
                   }
               }
           }
       }
       return %returnhash;
   }
   
   sub inst_userrules {
       my ($udom) = @_;
       my (%ruleshash,@ruleorder);
       if ($udom ne '') {
           my $homeserver=&domain($udom,'primary');
           if (($homeserver ne '') && ($homeserver ne 'no_host')) {
               my $response=&reply('instuserrules:'.&escape($udom),
                                    $homeserver);
               if (($response ne 'refused') && ($response ne 'error') && 
                   ($response ne 'no_such_host')) {
                   my ($hashitems,$orderitems) = split(/:/,$response);
                   my @pairs=split(/\&/,$hashitems);
                   foreach my $item (@pairs) {
                       my ($key,$value)=split(/=/,$item,2);
                       $key = &unescape($key);
                       next if ($key =~ /^error: 2 /);
                       $ruleshash{$key}=&thaw_unescape($value);
                   }
                   my @esc_order = split(/\&/,$orderitems);
                   foreach my $item (@esc_order) {
                       push(@ruleorder,&unescape($item));
                   }
               }
           }
       }
       return (\%ruleshash,\@ruleorder);
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 1205  sub do_cache_new { Line 1320  sub do_cache_new {
  $time=600;   $time=600;
     }      }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     if (!($memcache->set($id,$setvalue,$time))) {      my $result = $memcache->set($id,$setvalue,$time);
       if (! $result) {
  &logthis("caching of id -> $id  failed");   &logthis("caching of id -> $id  failed");
    $memcache->disconnect_all();
     }      }
     # need to make a copy of $value      # need to make a copy of $value
     #&make_room($id,$value,$debug);      #&make_room($id,$value,$debug);
Line 2081  sub flushcourselogs { Line 2198  sub flushcourselogs {
 #  #
     my %domrolebuffer = ();      my %domrolebuffer = ();
     foreach my $entry (keys %domainrolehash) {      foreach my $entry (keys %domainrolehash) {
         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;          my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
         if ($domrolebuffer{$rudom}) {          if ($domrolebuffer{$rudom}) {
             $domrolebuffer{$rudom}.='&'.&escape($entry).              $domrolebuffer{$rudom}.='&'.&escape($entry).
                       '='.&escape($domainrolehash{$entry});                        '='.&escape($domainrolehash{$entry});
Line 2203  sub userrolelog { Line 2320  sub userrolelog {
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                     = $tend.':'.$tstart;                      = $tend.':'.$tstart;
     }      }
     &flushcourselogs();  
 }  }
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
Line 4499  sub fetch_enrollment_query { Line 4615  sub fetch_enrollment_query {
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {      } else {
         my @responses = split/:/,$reply;          my @responses = split(/:/,$reply);
         if ($homeserver eq $perlvar{'lonHostID'}) {          if ($homeserver eq $perlvar{'lonHostID'}) {
             foreach my $line (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split(/=/,$line,2);                  my ($key,$value) = split(/=/,$line,2);
Line 4542  sub get_query_reply { Line 4658  sub get_query_reply {
  sleep 2;   sleep 2;
         if (-e $replyfile.'.end') {          if (-e $replyfile.'.end') {
     if (open(my $fh,$replyfile)) {      if (open(my $fh,$replyfile)) {
                $reply.=<$fh>;   $reply = join('',<$fh>);
                close($fh);   close($fh);
    } else { return 'error: reply_file_error'; }     } else { return 'error: reply_file_error'; }
            return &unescape($reply);             return &unescape($reply);
  }   }
Line 4609  sub auto_get_sections { Line 4725  sub auto_get_sections {
     my @secs = ();      my @secs = ();
     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));      my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
     unless ($response eq 'refused') {      unless ($response eq 'refused') {
         @secs = split/:/,$response;          @secs = split(/:/,$response);
     }      }
     return @secs;      return @secs;
 }  }
Line 4648  sub auto_create_password { Line 4764  sub auto_create_password {
         if ($response eq 'refused') {          if ($response eq 'refused') {
             $authchk = 'refused';              $authchk = 'refused';
         } else {          } else {
             ($authparam,$create_passwd,$authchk) = split/:/,$response;              ($authparam,$create_passwd,$authchk) = split(/:/,$response);
         }          }
     }      }
     return ($authparam,$create_passwd,$authchk);      return ($authparam,$create_passwd,$authchk);
Line 4756  sub auto_instcode_format { Line 4872  sub auto_instcode_format {
         $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);          $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
         if ($response !~ /(con_lost|error|no_such_host|refused)/) {          if ($response !~ /(con_lost|error|no_such_host|refused)/) {
             my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =               my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
  split/:/,$response;   split(/:/,$response);
             %{$codes} = (%{$codes},&str2hash($codes_str));              %{$codes} = (%{$codes},&str2hash($codes_str));
             push(@{$codetitles},&str2array($codetitles_str));              push(@{$codetitles},&str2array($codetitles_str));
             %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));              %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
Line 6306  sub EXT { Line 6422  sub EXT {
     my ($map) = &decode_symb($symbparm);      my ($map) = &decode_symb($symbparm);
     return &symbread($map);      return &symbread($map);
  }   }
    if ($space eq 'filename') {
       if ($symbparm) {
    return &clutter((&decode_symb($symbparm))[2]);
       }
       return &hreflocation('',$env{'request.filename'});
    }
   
  my ($section, $group, @groups);   my ($section, $group, @groups);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courselevel);
Line 6679  sub metadata { Line 6801  sub metadata {
  # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
  # as value   # as value
     $metaentry{':'.$unikey}=$default;      $metaentry{':'.$unikey}=$default;
  } else {   } elsif ( $internaltext =~ /\S/ ) {
   # either something interesting inside the tag or default    # something interesting inside the tag
                   # uninteresting  
     $metaentry{':'.$unikey}=$internaltext;      $metaentry{':'.$unikey}=$internaltext;
    } else {
     # no interesting values, don't set a default
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 6822  sub gettitle { Line 6945  sub gettitle {
  }   }
  my ($map,$resid,$url)=&decode_symb($symb);   my ($map,$resid,$url)=&decode_symb($symb);
  my $title='';   my $title='';
  my %bighash;   if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
  if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      $title = $env{'course.'.$env{'request.course.id'}.'.description'};
  &GDBM_READER(),0640)) {   } else {
     my $mapid=$bighash{'map_pc_'.&clutter($map)};      if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
     $title=$bighash{'title_'.$mapid.'.'.$resid};      &GDBM_READER(),0640)) {
     untie %bighash;   my $mapid=$bighash{'map_pc_'.&clutter($map)};
    $title=$bighash{'title_'.$mapid.'.'.$resid};
    untie(%bighash);
       }
  }   }
  $title=~s/\&colon\;/\:/gs;   $title=~s/\&colon\;/\:/gs;
  if ($title) {   if ($title) {
Line 8551  explanation of a user role term Line 8677  explanation of a user role term
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :
 All arguments are optional. Returns a hash of a roles, either for  All arguments are optional. Returns a hash of a roles, either for
 co-author/assistant author roles for a user's Construction Space  co-author/assistant author roles for a user's Construction Space
 (default), or if $context is 'user', roles for the user himself,  (default), or if $context is 'userroles', roles for the user himself,
 In the hash, keys are set to colon-sparated $uname,$udom,and $role,  In the hash, keys are set to colon-sparated $uname,$udom,and $role,
 and value is set to colon-separated start and end times for the role.  and value is set to colon-separated start and end times for the role.
 If no username and domain are specified, will default to current  If no username and domain are specified, will default to current
Removed from v.1.900  
changed lines
  Added in v.1.912

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