[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.76 and 1.80

version 1.76, 2000/12/06 19:58:31 version 1.80, 2000/12/13 22:45:22
Line 81 Line 81
 # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,   # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29, 
 # 10/30,10/31,  # 10/30,10/31,
 # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,  # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
 # 12/02 Gerd Kortemeyer  # 12/02,12/12,12/13 Gerd Kortemeyer
   
 package Apache::lonnet;  package Apache::lonnet;
   
Line 90  use Apache::File; Line 90  use Apache::File;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache $unique);  qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit %metacache);
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
Line 1187  sub assignrole { Line 1187  sub assignrole {
     return &reply($command,&homeserver($uname,$udom));      return &reply($command,&homeserver($uname,$udom));
 }  }
   
   # ----------------------------------------------------------------- Make a user
   
   
   sub makeuser {
       my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
       &logthis('Call to make user '.$udom.', '.$uname.', '.$uid.', '.
                $umode.', '.$first.', '.$middle.', '.
        $last.', '.$gene.' by '.
                $ENV{'user.name'}.' at '.$ENV{'user.domain'});  
       my $uhome=&homeserver($uname,$udom);
   # ----------------------------------------------------------------- Create User
       if ($uhome eq 'no_host') {
           my $unhome='';
    if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
       $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
    } elsif ($ENV{'user.domain'} eq $udom) {
               $unhome=$ENV{'user.home'};
           } else {
               my $tryserver;
               my $loadm=999999;
               foreach $tryserver (keys %libserv) {
          if ($hostdom{$tryserver} eq $udom) {
                     my $answer=reply('load',$tryserver);
                     if (($answer=~/\d+/) && ($answer<$loadm)) {
         $loadm=$answer;
                         $unhome=$tryserver;
                     }
          }
       }
           }
           if (($unhome eq '') || ($unhome eq 'no_host')) {
       return 'error: find home';
           }
           my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
                            &escape($upass),$unhome);
    unless ($reply eq 'ok') {
               return 'error: '.$reply;
           }   
           $uhome=&homeserver($uname,$udom);
           if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
       return 'error: verify home';
           }
       }
   # ---------------------------------------------------------------------- Add ID
       if ($uid) {
          $uid=~tr/A-Z/a-z/;
          my %uidhash=&idrget($udom,$uname);
          if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) {
     unless ($uid eq $uidhash{$uname}) {
         return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
             }
          } else {
     &idput($udom,($uname => $uid));
          }
       }
   # -------------------------------------------------------------- Add names, etc
       my $names=&reply('get:'.$udom.':'.$uname.
                        ':environment:firstname&middlename&lastname&generation',
                        $uhome);
       my ($efirst,$emiddle,$elast,$egene)=split(/\&/,$names);
       unless ($efirst)  { $efirst  = &escape($first); }
       unless ($emiddle) { $emiddle = &escape($middle); }
       unless ($elast)   { $elast   = &escape($last); }
       unless ($egene)   { $egene   = &escape($gene); }
       my $reply=&reply('put:'.$udom.':'.$uname.
              ':environment:firstname='.$efirst.
                         '&middlename='.$emiddle.
                           '&lastname='.$elast.
                         '&generation='.$egene,$uhome);
       if ($reply ne 'ok') {
    return 'error: '.$reply;
       }
       &logthis('Success making user '.$udom.', '.$uname.', '.$uid.', '.
                $umode.', '.$first.', '.$middle.', '.
        $last.', '.$gene.' by '.
                $ENV{'user.name'}.' at '.$ENV{'user.domain'});
       return 'ok'; 
   }
   
   # -------------------------------------------------------------- Make a student
   
   sub makestudent {
       my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec)=@_;
       unless ($ENV{'request.course.id'}) {
    return 'not_in_class';
       }
   # --------------------------------------------------------------- Make the user
       my $reply=&makeuser
    ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene);
       unless ($reply eq 'ok') { return $reply; }
   # -------------------------------------------------- Add student to course list
   
   # ---------------------------------------------------- Add student role to user
   
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
Line 1426  sub EXT { Line 1522  sub EXT {
         my $reply=&reply('get:'.          my $reply=&reply('get:'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.                $ENV{'course.'.$ENV{'request.course.id'}.$section.'.domain'}.':'.
               $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.                $ENV{'course.'.$ENV{'request.course.id'}.$section.'.num'}.
               ':resourcedata:'.        ':resourcedata:'.
  escape($seclevelr).':'.escape($seclevelm).':'.escape($seclevel).':'.     &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
  escape($courselevelr).':'.escape($courselevelm).':'.escape($courselevel),     &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
    $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});     $ENV{'course.'.$ENV{'request.course.id'}.$section.'.home'});
       if ($reply!~/^error\:/) {        if ($reply!~/^error\:/) {
         map {    map {
            my ($name,$value)=split(/\=/,$_);        if ($_) { return &unescape($_); }
            $resourcedata{unescape($name)}=unescape($value);              } split(/\&/,$reply);
         } split(/\&/,$reply);  
   
        if ($resourcedata{$seclevelr}) { return $resourcedata{$seclevelr}; }  
        if ($resourcedata{$seclevelm}) { return $resourcedata{$seclevelm}; }    
        if ($resourcedata{$seclevel}) { return $resourcedata{$seclevel}; }  
   
        if ($resourcedata{$courselevelr}) {   
           return $resourcedata{$courselevelr}; }  
        if ($resourcedata{$courselevelm}) {   
           return $resourcedata{$courselevelm}; }  
        if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }  
   
       }        }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
Line 1461  sub EXT { Line 1545  sub EXT {
             
 # --------------------------------------------- last, look in resource metadata  # --------------------------------------------- last, look in resource metadata
   
         $spacequalifierrest=~s/\./\_/;
       my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);        my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
       if ($metadata) { return $metadata; }        if ($metadata) { return $metadata; }
         $metadata=&metadata($ENV{'request.filename'},
                                            'parameter_'.$spacequalifierrest);
         if ($metadata) { return $metadata; }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
Line 1481  sub EXT { Line 1569  sub EXT {
   
 sub metadata {  sub metadata {
     my ($uri,$what)=@_;      my ($uri,$what)=@_;
   
     $uri=&declutter($uri);      $uri=&declutter($uri);
     my $filename=$uri;      my $filename=$uri;
     $uri=~s/\.meta$//;      $uri=~s/\.meta$//;
Line 1507  sub metadata { Line 1596  sub metadata {
               map {                map {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};    $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               } @{$token->[3]};                } @{$token->[3]};
               $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry);                unless (
                    $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
         ) { $metacache{$uri.':'.$unikey}=
         $metacache{$uri.':'.$unikey.'.default'};
         }
           }            }
        }         }
     }      }
Line 1639  sub ireceipt { Line 1732  sub ireceipt {
     my $cudom=unpack("%32C*",$fudom);      my $cudom=unpack("%32C*",$fudom);
     my $cucourseid=unpack("%32C*",$fucourseid);      my $cucourseid=unpack("%32C*",$fucourseid);
     my $cusymb=unpack("%32C*",$fusymb);      my $cusymb=unpack("%32C*",$fusymb);
     my $cunique=unpack("%32C*",$unique);      my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
     return unpack("%32C*",$perlvar{'lonHostID'}).'-'.      return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
            ($cunique%$cuname+             ($cunique%$cuname+
             $cunique%$cudom+              $cunique%$cudom+
Line 1800  if ($readit ne 'done') { Line 1893  if ($readit ne 'done') {
     }      }
 }  }
   
 # --------------------------------------------------- Get CPU data as unique ID  
 {  
    my @contents;  
    {  
     my $fh=Apache::File->new('/proc/cpuinfo');  
     @contents=<$fh>;  
    }  
    $unique='';  
    map {  
        my ($name,$value)=split(/\s*\:\s*/,$_);  
        if (($name eq 'vendor_id') || ($name=~/^model/) ||  
            ($name=~/^cpu/) || ($name eq 'stepping')) {  
    $unique.=$value;  
        }   
    } @contents;  
    $unique=~s/\W//g;  
 }  
   
 %metacache=();  %metacache=();
   
 $readit='done';  $readit='done';
Removed from v.1.76  
changed lines
  Added in v.1.80

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