[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.346 and 1.353

version 1.346, 2003/03/23 01:46:51 version 1.353, 2003/03/26 04:57:04
Line 74  use HTTP::Headers; Line 74  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %iphost %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab %titlecache      %libserv %pr %prp %metacache %packagetab %titlecache 
    %courselogs %accesshash $processmarker $dumpcount      %courselogs %accesshash %userrolehash $processmarker $dumpcount 
    %coursedombuf %coursehombuf %courseresdatacache      %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseresdatacache 
    %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);     %domaindescription %domain_auth_def %domain_auth_arg_def $tmpdir);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
Line 600  sub assign_access_key { Line 600  sub assign_access_key {
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     if (($existing{$ckey}=~/^\d+$/) || # has time - new key      if (($existing{$ckey}=~/^\d+$/) || # has time - new key
         ($existing{$ckey} eq $udom.':'.$uname)) { # this should not happen,          ($existing{$ckey} eq $uname.':'.$udom)) { # this should not happen,
                                                   # unless something went wrong                                                    # unless something went wrong
                                                   # the first time around                                                    # the first time around
 # ready to assign  # ready to assign
     } elsif (!$existing{$ckey}) {      } elsif (!$existing{$ckey}) {
         if (&put('accesskey',{$ckey=>$udom.':'.$uname},$cdom,$cnum) eq 'ok') {          if (&put('accesskey',{$ckey=>$uname.':'.$udom},$cdom,$cnum) eq 'ok') {
 # key now belongs to user  # key now belongs to user
     my $envkey='key.'.$cdom.'_'.$cnum;      my $envkey='key.'.$cdom.'_'.$cnum;
             if (&put('environment',{$envkey => $ckey}) eq 'ok') {              if (&put('environment',{$envkey => $ckey}) eq 'ok') {
Line 671  sub validate_access_key { Line 671  sub validate_access_key {
     $udom=$ENV{'user.name'} unless (defined($udom));      $udom=$ENV{'user.name'} unless (defined($udom));
     $uname=$ENV{'user.domain'} unless (defined($uname));      $uname=$ENV{'user.domain'} unless (defined($uname));
     my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);      my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
     return ($existing{$ckey} eq $udom.':'.$uname);      return ($existing{$ckey} eq $uname.':'.$udom);
 }  }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
Line 1027  sub log { Line 1027  sub log {
 }  }
   
 # ------------------------------------------------------------------ Course Log  # ------------------------------------------------------------------ Course Log
   #
   # This routine flushes several buffers of non-mission-critical nature
   #
   
 sub flushcourselogs {  sub flushcourselogs {
     &logthis('Flushing course log buffers');      &logthis('Flushing log buffers');
   #
   # course logs
   # This is a log of all transactions in a course, which can be used
   # for data mining purposes
   #
   # It also collects the courseid database, which lists last transaction
   # times and course titles for all courseids
   #
       my %courseidbuffer=();
     foreach (keys %courselogs) {      foreach (keys %courselogs) {
         my $crsid=$_;          my $crsid=$_;
         if (&reply('log:'.$coursedombuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
     delete $courselogs{$crsid};      delete $courselogs{$crsid};
Line 1043  sub flushcourselogs { Line 1055  sub flushcourselogs {
                         " exceeded maximum size, deleting.</font>");                          " exceeded maximum size, deleting.</font>");
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
         }                  }
           if ($courseidbuffer{$coursehombuf{$crsid}}) {
              $courseidbuffer{$coursehombuf{$crsid}}.='&'.
    &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
           } else {
              $courseidbuffer{$coursehombuf{$crsid}}=
    &escape($crsid).'='.&escape($coursedescrbuf{$crsid});
           }    
       }
   #
   # Write course id database (reverse lookup) to homeserver of courses 
   # Is used in pickcourse
   #
       foreach (keys %courseidbuffer) {
           &courseidput($hostdom{$_},$courseidbuffer{$_},$_);
     }      }
     &logthis('Flushing access logs');  #
   # File accesses
   # Writes to the dynamic metadata of resources to get hit counts, etc.
   #
     foreach (keys %accesshash) {      foreach (keys %accesshash) {
         my $entry=$_;          my $entry=$_;
         $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;          $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
Line 1054  sub flushcourselogs { Line 1083  sub flushcourselogs {
     delete $accesshash{$entry};      delete $accesshash{$entry};
         }          }
     }      }
   #
   # Roles
   # Reverse lookup of user roles for course faculty/staff and co-authorship
   #
       foreach (keys %userrolehash) {
           my $entry=$_;
           my ($role,$uname,$udom,$runame,$rudom,$rsec)=
       split(/\:/,$entry);
           if (&Apache::lonnet::put('nohist_userroles',
                { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} },
                   $rudom,$runame) eq 'ok') {
       delete $userrolehash{$entry};
           }
       }
     $dumpcount++;      $dumpcount++;
 }  }
   
Line 1062  sub courselog { Line 1105  sub courselog {
     $what=time.':'.$what;      $what=time.':'.$what;
     unless ($ENV{'request.course.id'}) { return ''; }      unless ($ENV{'request.course.id'}) { return ''; }
     $coursedombuf{$ENV{'request.course.id'}}=      $coursedombuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.         $ENV{'course.'.$ENV{'request.course.id'}.'.domain'};
       $coursenumbuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.num'};         $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
     $coursehombuf{$ENV{'request.course.id'}}=      $coursehombuf{$ENV{'request.course.id'}}=
        $ENV{'course.'.$ENV{'request.course.id'}.'.home'};         $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
       $coursedescrbuf{$ENV{'request.course.id'}}=
          $ENV{'course.'.$ENV{'request.course.id'}.'.description'};
     if (defined $courselogs{$ENV{'request.course.id'}}) {      if (defined $courselogs{$ENV{'request.course.id'}}) {
  $courselogs{$ENV{'request.course.id'}}.='&'.$what;   $courselogs{$ENV{'request.course.id'}}.='&'.$what;
     } else {      } else {
Line 1102  sub countacc { Line 1148  sub countacc {
         $accesshash{$key}=1;          $accesshash{$key}=1;
     }      }
 }  }
       
   sub userrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
       if (($trole=~/^ca/) || ($trole=~/^in/) || 
           ($trole=~/^cc/) || ($trole=~/^ep/) ||
           ($trole=~/^cr/)) {
          my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
          $userrolehash
            {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                       =$tend.':'.$tstart;
      }
   }
   
   sub get_course_adv_roles {
       my $cid=shift;
       $cid=$ENV{'request.course.id'} unless (defined($cid));
       my %coursehash=&coursedescription($cid);
       my %returnhash=();
       my %dumphash=
               &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
       my $now=time;
       foreach (keys %dumphash) {
    my ($tend,$tstart)=split(/\:/,$dumphash{$_});
           if (($tstart) && ($tstart<0)) { next; }
           if (($tend) && ($tend<$now)) { next; }
           if (($tstart) && ($now<$tstart)) { next; }
           my ($role,$username,$domain,$section)=split(/\:/,$_);
           my $key=&plaintext($role);
           if ($section) { $key.=' (Sec/Grp '.$section.')'; }
           if ($returnhash{$key}) {
       $returnhash{$key}.=','.$username.':'.$domain;
           } else {
               $returnhash{$key}=$username.':'.$domain;
           }
       }
       return sort %returnhash;
   }
   
   # ---------------------------------------------------------- Course ID routines
   # Deal with domain's nohist_courseid.db files
   #
   
   sub courseidput {
       my ($domain,$what,$coursehome)=@_;
       return &reply('courseidput:'.$domain.':'.$what,$coursehome);
   }
   
   sub courseiddump {
       my ($domfilter,$descfilter,$sincefilter)=@_;
       my %returnhash=();
       foreach my $tryserver (keys %libserv) {
    if ($hostdom{$tryserver}=~/$domfilter/) {
       foreach (
                split(/\&/,&reply('courseiddump:'.$hostdom{$tryserver}.':'.
          $sincefilter.':'.&escape($descfilter)))) {
    my ($key,$value)=split(/\=/,$_);
                   if (($key) && ($value)) {
       $returnhash{&unescape($key)}=&unescape($value);
                   }
               }
   
           }
       }
       return %returnhash;
   }
   
   #
 # ----------------------------------------------------------- Check out an item  # ----------------------------------------------------------- Check out an item
   
 sub checkout {  sub checkout {
Line 1707  sub rolesinit { Line 1819  sub rolesinit {
             my ($trole,$tend,$tstart)=split(/_/,$role);              my ($trole,$tend,$tstart)=split(/_/,$role);
             $userroles.='user.role.'.$trole.'.'.$area.'='.              $userroles.='user.role.'.$trole.'.'.$area.'='.
                         $tstart.'.'.$tend."\n";                          $tstart.'.'.$tend."\n";
   # log the associated role with the area
               &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
             if ($tend!=0) {              if ($tend!=0) {
         if ($tend<$now) {          if ($tend<$now) {
             $trole='';              $trole='';
Line 1718  sub rolesinit { Line 1832  sub rolesinit {
                 }                  }
             }              }
             if (($area ne '') && ($trole ne '')) {              if (($area ne '') && ($trole ne '')) {
        my $spec=$trole.'.'.$area;   my $spec=$trole.'.'.$area;
                my ($tdummy,$tdomain,$trest)=split(/\//,$area);   my ($tdummy,$tdomain,$trest)=split(/\//,$area);
                if ($trole =~ /^cr\//) {   if ($trole =~ /^cr\//) {
    my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
                    my $homsvr=homeserver($rauthor,$rdomain);      my $homsvr=homeserver($rauthor,$rdomain);
                    if ($hostname{$homsvr} ne '') {      if ($hostname{$homsvr} ne '') {
                       my $roledef=   my $roledef=
   reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",      reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
                                 $homsvr);    $homsvr);
                       if (($roledef ne 'con_lost') && ($roledef ne '')) {   if (($roledef ne 'con_lost') && ($roledef ne '')) {
                          my ($syspriv,$dompriv,$coursepriv)=      my ($syspriv,$dompriv,$coursepriv)=
      split(/\_/,unescape($roledef));   split(/\_/,unescape($roledef));
                   $allroles{'cm./'}.=':'.$syspriv;      if (defined($syspriv)) {
                          $allroles{$spec.'./'}.=':'.$syspriv;   $allroles{'cm./'}.=':'.$syspriv;
                          if ($tdomain ne '') {   $allroles{$spec.'./'}.=':'.$syspriv;
                              $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;      }
                              $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;      if ($tdomain ne '') {
                              if ($trest ne '') {   if (defined($dompriv)) {
                 $allroles{'cm.'.$area}.=':'.$coursepriv;      $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
                 $allroles{$spec.'.'.$area}.=':'.$coursepriv;      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
                              }   }
                  }   if ($trest ne '') {
                       }      if (defined($coursepriv)) {
                    }   $allroles{'cm.'.$area}.=':'.$coursepriv;
                } else {   $allroles{$spec.'.'.$area}.=':'.$coursepriv;
            $allroles{'cm./'}.=':'.$pr{$trole.':s'};      }
            $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};   }
                    if ($tdomain ne '') {      }
                      $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};   }
                      $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};      }
                       if ($trest ne '') {   } else {
           $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};      if (defined($pr{$trole.':s'})) {
           $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};   $allroles{'cm./'}.=':'.$pr{$trole.':s'};
                       }   $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
            }      }
        }      if ($tdomain ne '') {
    if (defined($pr{$trole.':d'})) {
       $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
       $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
    }
    if ($trest ne '') {
       if (defined($pr{$trole.':c'})) {
    $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
    $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
       }
    }
       }
    }
             }              }
           }             } 
         }          }
Line 2453  sub assignrole { Line 2579  sub assignrole {
            $command.='_0_'.$start;             $command.='_0_'.$start;
         }          }
     }      }
     return &reply($command,&homeserver($uname,$udom));      my $answer=&reply($command,&homeserver($uname,$udom));
       if ($answer eq 'ok') {
    &userrolelog($mrole,$uname,$udom,$url,$start,$end);
       }
       return $answer;
 }  }
   
 # -------------------------------------------------- Modify user authentication  # -------------------------------------------------- Modify user authentication
Removed from v.1.346  
changed lines
  Added in v.1.353

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