[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.932 and 1.948

version 1.932, 2007/12/21 04:14:24 version 1.948, 2008/03/10 23:26:28
Line 1064  sub inst_rulecheck { Line 1064  sub inst_rulecheck {
                     $response=&unescape(&reply('instidrulecheck:'.&escape($udom).                      $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                               ':'.&escape($id).':'.$rulestr,                                                ':'.&escape($id).':'.$rulestr,
                                               $homeserver));                                                $homeserver));
                   } elsif ($item eq 'selfcreate') {
                       $response=&unescape(&reply('instselfcreatecheck:'.
                                                  &escape($udom).':'.&escape($uname).
                                                 ':'.$rulestr,$homeserver));
                 }                  }
                 if ($response ne 'refused') {                  if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);                      my @pairs=split(/\&/,$response);
Line 1090  sub inst_userrules { Line 1094  sub inst_userrules {
             if ($check eq 'id') {              if ($check eq 'id') {
                 $response=&reply('instidrules:'.&escape($udom),                  $response=&reply('instidrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
               } elsif ($check eq 'email') {
                   $response=&reply('instemailrules:'.&escape($udom),
                                    $homeserver);
             } else {              } else {
                 $response=&reply('instuserrules:'.&escape($udom),                  $response=&reply('instuserrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
Line 1115  sub inst_userrules { Line 1122  sub inst_userrules {
     return (\%ruleshash,\@ruleorder);      return (\%ruleshash,\@ruleorder);
 }  }
   
   # ------------------------- Get Authentication and Language Defaults for Domain
   
   sub get_domain_defaults {
       my ($domain) = @_;
       my $cachetime = 60*60*24;
       my ($defauthtype,$defautharg,$deflang);
       my ($result,$cached)=&is_cached_new('domdefaults',$domain);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               return %{$result};
           }
       }
       my %domdefaults;
       my %domconfig =
            &Apache::lonnet::get_dom('configuration',['defaults'],$domain);
       if (ref($domconfig{'defaults'}) eq 'HASH') {
           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
           $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
           $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
       } else {
           $domdefaults{'lang_def'} = &domain($domain,'lang_def');
           $domdefaults{'auth_def'} = &domain($domain,'auth_def');
           $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
       }
       &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                     $cachetime);
       return %domdefaults;
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 1650  sub absolute_url { Line 1686  sub absolute_url {
     return $protocol.$host_name;      return $protocol.$host_name;
 }  }
   
   #
   #   Server side include.
   # Parameters:
   #  fn     Possibly encrypted resource name/id.
   #  form   Hash that describes how the rendering should be done
   #         and other things.
   # Returns:
   #   Scalar context: The content of the reply.
   #   Array context:  2 element list of the content and the full response variable.
   #     
   # Returns:
   #    The content of the response.
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
       my $count = scalar(@_);
       
   
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
           
Line 1669  sub ssi { Line 1719  sub ssi {
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);      my $response=$ua->request($request);
       my $status = $response->code;
   
     return $response->content;      if (wantarray) {
    return ($response->content, $response);
       } else {
    return $response->content;
       }
 }  }
   
 sub externalssi {  sub externalssi {
Line 2200  sub flushcourselogs { Line 2255  sub flushcourselogs {
             }              }
         }          }
         $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {          $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
             'description' => &escape($coursedescrbuf{$crsid}),              'description' => $coursedescrbuf{$crsid},
             'inst_code'    => &escape($courseinstcodebuf{$crsid}),              'inst_code'    => $courseinstcodebuf{$crsid},
             'type'        => &escape($coursetypebuf{$crsid}),              'type'        => $coursetypebuf{$crsid},
             'owner'       => &escape($courseownerbuf{$crsid}),              'owner'       => $courseownerbuf{$crsid},
         };          };
     }      }
 #  #
Line 2394  sub userrolelog { Line 2449  sub userrolelog {
 }  }
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my $cid=shift;      my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
     my %coursehash=&coursedescription($cid);      my %coursehash=&coursedescription($cid);
     my %nothide=();      my %nothide=();
     foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {      foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
  $nothide{join(':',split(/[\@\:]/,$user))}=1;          if ($user !~ /:/) {
       $nothide{join(':',split(/[\@]/,$user))}=1;
           } else {
               $nothide{$user}=1;
           }
     }      }
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
Line 2415  sub get_course_adv_roles { Line 2474  sub get_course_adv_roles {
  if ((&privileged($username,$domain)) &&    if ((&privileged($username,$domain)) && 
     (!$nothide{$username.':'.$domain})) { next; }      (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         my $key=&plaintext($role);          if ($codes) {
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }              if ($section) { $role .= ':'.$section; }
         if ($returnhash{$key}) {              if ($returnhash{$role}) {
     $returnhash{$key}.=','.$username.':'.$domain;                  $returnhash{$role}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$role}=$username.':'.$domain;
               }
         } else {          } else {
             $returnhash{$key}=$username.':'.$domain;              my $key=&plaintext($role);
               if ($section) { $key.=' (Section '.$section.')'; }
               if ($returnhash{$key}) {
           $returnhash{$key}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$key}=$username.':'.$domain;
               }
         }          }
      }      }
     return %returnhash;      return %returnhash;
 }  }
   
 sub get_my_roles {  sub get_my_roles {
     my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;      my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
     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;      my (%dumphash,%nothide);
     if ($context eq 'userroles') {       if ($context eq 'userroles') { 
         %dumphash = &dump('roles',$udom,$uname);          %dumphash = &dump('roles',$udom,$uname);
     } else {      } else {
         %dumphash=          %dumphash=
             &dump('nohist_userroles',$udom,$uname);              &dump('nohist_userroles',$udom,$uname);
           if ($hidepriv) {
               my %coursehash=&coursedescription($udom.'_'.$uname);
               foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
                   if ($user !~ /:/) {
                       $nothide{join(':',split(/[\@]/,$user))} = 1;
                   } else {
                       $nothide{$user} = 1;
                   }
               }
           }
     }      }
     my %returnhash=();      my %returnhash=();
     my $now=time;      my $now=time;
Line 2448  sub get_my_roles { Line 2526  sub get_my_roles {
         }          }
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
         my $status = 'active';          my $status = 'active';
         if (($tend) && ($tend<$now)) {          if (($tend) && ($tend<=$now)) {
             $status = 'previous';              $status = 'previous';
         }           } 
         if (($tstart) && ($now<$tstart)) {          if (($tstart) && ($now<$tstart)) {
Line 2486  sub get_my_roles { Line 2564  sub get_my_roles {
                 }                  }
             }              }
         }          }
  $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;          if ($hidepriv) {
               if ((&privileged($username,$domain)) &&
                   (!$nothide{$username.':'.$domain})) { 
                   next;
               }
           }
           if ($withsec) {
               $returnhash{$username.':'.$domain.':'.$role.':'.$section} =
                   $tstart.':'.$tend;
           } else {
               $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
           }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 2550  sub courseidput { Line 2639  sub courseidput {
         foreach my $cid (keys(%$storehash)) {          foreach my $cid (keys(%$storehash)) {
             $what .= &escape($cid).'=';              $what .= &escape($cid).'=';
             foreach my $item ('description','inst_code','owner','type') {              foreach my $item ('description','inst_code','owner','type') {
                 $what .= &escape($storehash->{$item}).':';                  $what .= &escape($storehash->{$cid}{$item}).':';
             }              }
             $what =~ s/\:$/&/;              $what =~ s/\:$/&/;
         }          }
Line 2563  sub courseidput { Line 2652  sub courseidput {
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
           $selfenrollonly)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 2580  sub courseiddump { Line 2670  sub courseiddump {
                          $sincefilter.':'.&escape($descfilter).':'.                           $sincefilter.':'.&escape($descfilter).':'.
                          &escape($instcodefilter).':'.&escape($ownerfilter).                           &escape($instcodefilter).':'.&escape($ownerfilter).
                          ':'.&escape($coursefilter).':'.&escape($typefilter).                           ':'.&escape($coursefilter).':'.&escape($typefilter).
                          ':'.&escape($regexp_ok).':'.$as_hash,$tryserver);                           ':'.&escape($regexp_ok).':'.$as_hash.':'.
                            &escape($selfenrollonly),$tryserver);
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 3502  sub set_userprivs { Line 3593  sub set_userprivs {
     }      }
     foreach my $role (keys(%{$allroles})) {      foreach my $role (keys(%{$allroles})) {
         my %thesepriv;          my %thesepriv;
         if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }          if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; }
         foreach my $item (split(/:/,$$allroles{$role})) {          foreach my $item (split(/:/,$$allroles{$role})) {
             if ($item ne '') {              if ($item ne '') {
                 my ($privilege,$restrictions)=split(/&/,$item);                  my ($privilege,$restrictions)=split(/&/,$item);
Line 4843  sub auto_run { Line 4934  sub auto_run {
             $response = 1;              $response = 1;
         }          }
     } else {      } else {
         my $homeserver = &homeserver($cnum,$cdom);          my $homeserver;
         $response = &reply('autorun:'.$cdom,$homeserver);          if (&is_course($cdom,$cnum)) {
               $homeserver = &homeserver($cnum,$cdom);
           } else {
               $homeserver = &domain($cdom,'primary');
           }
           if ($homeserver ne 'no_host') {
               $response = &reply('autorun:'.$cdom,$homeserver);
           }
     }      }
     return $response;      return $response;
 }  }
Line 5225  sub plaintext { Line 5323  sub plaintext {
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
   
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;      my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll)=@_;
     my $mrole;      my $mrole;
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
Line 5259  sub assignrole { Line 5357  sub assignrole {
             } else {              } else {
                 $refused = 1;                  $refused = 1;
             }              }
             if ($refused) {               if ($refused) {
                 &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                  if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                          ' '.$role.' '.$end.' '.$start.' by '.                      $refused = '';
            $env{'user.name'}.' at '.$env{'user.domain'});                  } else {
                 return 'refused';                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
                                ' '.$role.' '.$end.' '.$start.' by '.
                  $env{'user.name'}.' at '.$env{'user.domain'});
                       return 'refused';
                   }
             }              }
         }          }
         $mrole=$role;          $mrole=$role;
Line 5457  sub modifystudent { Line 5559  sub modifystudent {
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 5515  sub modify_student_enrollment { Line 5617  sub modify_student_enrollment {
     if ($usec) {      if ($usec) {
  $uurl.='/'.$usec;   $uurl.='/'.$usec;
     }      }
     return &assignrole($udom,$uname,$uurl,'st',$end,$start);      return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll);
 }  }
   
 sub format_name {  sub format_name {
Line 5634  ENDINITMAP Line 5736  ENDINITMAP
 sub is_course {  sub is_course {
     my ($cdom,$cnum) = @_;      my ($cdom,$cnum) = @_;
     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,      my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
  undef,'.',undef,1);   undef,'.');
     if (exists($courses{$cdom.'_'.$cnum})) {      if (exists($courses{$cdom.'_'.$cnum})) {
         return 1;          return 1;
     }      }
Line 6685  sub EXT { Line 6787  sub EXT {
     if ($part eq '') { $part='0'; }      if ($part eq '') { $part='0'; }
     my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,      my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
  $symbparm,$udom,$uname,$section,1);   $symbparm,$udom,$uname,$section,1);
     if (@partgeneral) { return &get_reply(\@partgeneral); }      if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
  }   }
  if ($recurse) { return undef; }   if ($recurse) { return undef; }
  my $pack_def=&packages_tab_default($filename,$varname);   my $pack_def=&packages_tab_default($filename,$varname);
Line 6719  sub EXT { Line 6821  sub EXT {
   
 sub get_reply {  sub get_reply {
     my ($reply_value) = @_;      my ($reply_value) = @_;
     if (wantarray) {      if (ref($reply_value) eq 'ARRAY') {
  return @$reply_value;          if (wantarray) {
       return @$reply_value;
           }
           return $reply_value->[0];
       } else {
           return $reply_value;
     }      }
     return $reply_value->[0];  
 }  }
   
 sub check_group_parms {  sub check_group_parms {
Line 8855  explanation of a user role term Line 8961  explanation of a user role term
   
 =item *  =item *
   
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
 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 'userroles', 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-separated $uname,$udom,$role, and
 and value is set to colon-separated start and end times for the role.  (optionally) if $withsec is true, a fourth colon-separated item - $section.
 If no username and domain are specified, will default to current  For each key, value is set to colon-separated start and end times for
 user/domain. Types, roles, and roledoms are references to arrays,  the role.  If no username and domain are specified, will default to
   current user/domain. Types, roles, and roledoms are references to arrays
 of role statuses (active, future or previous), roles   of role statuses (active, future or previous), roles 
 (e.g., cc,in, st etc.) and domains of the roles which can be used  (e.g., cc,in, st etc.) and domains of the roles which can be used
 to restrict the list of roles reported. If no array ref is   to restrict the list of roles reported. If no array ref is 
Line 9309  put_dom($namespace,$storehash,$udom,$uho Line 9416  put_dom($namespace,$storehash,$udom,$uho
 domain level either on specified domain server ($uhome) or primary domain   domain level either on specified domain server ($uhome) or primary domain 
 server ($udom and $uhome are optional)  server ($udom and $uhome are optional)
   
   =item * 
   
   get_domain_defaults($target_domain) : returns hash with defaults for
   authentication and language in the domain. Keys are: auth_def, auth_arg_def,
   lang_def; corresponsing values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us).
   Values are retrieved from cache (if current), or from domain's configuration.db
   (if available), or lastly from values in lonTabs/dns_domain,tab, 
   or lonTabs/domain.tab. 
   
   %domdefaults = &get_auth_defaults($target_domain);
   
 =back  =back
   
 =head2 Network Status Functions  =head2 Network Status Functions
Removed from v.1.932  
changed lines
  Added in v.1.948

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