[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.219 and 1.237

version 1.219, 2002/05/13 09:32:56 version 1.237, 2002/06/14 20:47:45
Line 77  use Apache::File; Line 77  use Apache::File;
 use LWP::UserAgent();  use LWP::UserAgent();
 use HTTP::Headers;  use HTTP::Headers;
 use vars   use vars 
 qw(%perlvar %hostname %homecache %hostip %spareid %hostdom   qw(%perlvar %hostname %homecache %badServerCache %hostip %spareid %hostdom 
    %libserv %pr %prp %metacache %packagetab      %libserv %pr %prp %metacache %packagetab 
    %courselogs %accesshash $processmarker $dumpcount      %courselogs %accesshash $processmarker $dumpcount 
    %coursedombuf %coursehombuf %courseresdatacache);     %coursedombuf %coursehombuf %courseresdatacache);
Line 140  sub reply { Line 140  sub reply {
     unless (defined($hostname{$server})) { return 'no_such_host'; }      unless (defined($hostname{$server})) { return 'no_such_host'; }
     my $answer=subreply($cmd,$server);      my $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
        sleep 5;          #sleep 5; 
        $answer=subreply($cmd,$server);         #$answer=subreply($cmd,$server);
        if ($answer eq 'con_lost') {         #if ($answer eq 'con_lost') {
    &logthis("Second attempt con_lost on $server");   #   &logthis("Second attempt con_lost on $server");
            my $peerfile="$perlvar{'lonSockDir'}/$server";          #   my $peerfile="$perlvar{'lonSockDir'}/$server";
            my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",          #   my $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                             Type    => SOCK_STREAM,          #                                    Type    => SOCK_STREAM,
                                             Timeout => 10)          #                                    Timeout => 10)
                       or return "con_lost";          #              or return "con_lost";
            &logthis("Killing socket");          #   &logthis("Killing socket");
            print $client "close_connection_exit\n";          #   print $client "close_connection_exit\n";
            sleep 5;             #sleep 5;
            $answer=subreply($cmd,$server);                 #   $answer=subreply($cmd,$server);       
        }            #}   
     }      }
     if (($answer=~/^refused/) || ($answer=~/^rejected/)) {      if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
        &logthis("<font color=blue>WARNING:".         &logthis("<font color=blue>WARNING:".
Line 481  sub authenticate { Line 481  sub authenticate {
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
 sub homeserver {  sub homeserver {
     my ($uname,$udom)=@_;      my ($uname,$udom,$ignoreBadCache)=@_;
   
     my $index="$uname:$udom";      my $index="$uname:$udom";
     if ($homecache{$index}) { return "$homecache{$index}"; }      if ($homecache{$index}) { 
           return "$homecache{$index}"; 
       }
     my $tryserver;      my $tryserver;
     foreach $tryserver (keys %libserv) {      foreach $tryserver (keys %libserv) {
           next if ($ignoreBadCache ne 'true' && 
    exists($badServerCache{$tryserver}));
  if ($hostdom{$tryserver} eq $udom) {   if ($hostdom{$tryserver} eq $udom) {
            my $answer=reply("home:$udom:$uname",$tryserver);             my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') {              if ($answer eq 'found') { 
       $homecache{$index}=$tryserver;                $homecache{$index}=$tryserver;
               return $tryserver;                 return $tryserver; 
    }             } elsif ($answer eq 'no_host') {
          $badServerCache{$tryserver}=1;
              }
        }         }
     }          }    
     return 'no_host';      return 'no_host';
Line 795  sub checkout { Line 799  sub checkout {
     my $now=time;      my $now=time;
     my $lonhost=$perlvar{'lonHostID'};      my $lonhost=$perlvar{'lonHostID'};
     my $infostr=&escape(      my $infostr=&escape(
                    'CHECKOUTTOKEN&'.
                  $tuname.'&'.                   $tuname.'&'.
                  $tudom.'&'.                   $tudom.'&'.
                  $tcrsid.'&'.                   $tcrsid.'&'.
Line 844  sub checkin { Line 849  sub checkin {
     $lonhost=~tr/A-Z/a-z/;      $lonhost=~tr/A-Z/a-z/;
     my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;      my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
     $dtoken=~s/\W/\_/g;      $dtoken=~s/\W/\_/g;
     my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=      my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));                   split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
   
     unless (($tuname) && ($tudom)) {      unless (($tuname) && ($tudom)) {
Line 1544  sub allowed { Line 1549  sub allowed {
 # the course  # the course
   
     if ($ENV{'request.course.id'}) {      if ($ENV{'request.course.id'}) {
   
        $courseprivid=$ENV{'request.course.id'};         $courseprivid=$ENV{'request.course.id'};
        if ($ENV{'request.course.sec'}) {         if ($ENV{'request.course.sec'}) {
           $courseprivid.='/'.$ENV{'request.course.sec'};            $courseprivid.='/'.$ENV{'request.course.sec'};
        }         }
        $courseprivid=~s/\_/\//;         $courseprivid=~s/\_/\//;
        my $checkreferer=1;         my $checkreferer=1;
        my @uriparts=split(/\//,$uri);         my ($match,$cond)=&is_on_map($uri);
        my $filename=$uriparts[$#uriparts];         if ($match) {
        my $pathname=$uri;             $statecond=$cond;
        $pathname=~s/\/$filename$//;  
        if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~  
            /\&$filename\:([\d\|]+)\&/) {  
            $statecond=$1;  
            if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}             if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                =~/$priv\&([^\:]*)/) {                 =~/$priv\&([^\:]*)/) {
                $thisallowed.=$1;                 $thisallowed.=$1;
Line 1566  sub allowed { Line 1568  sub allowed {
                 
        if ($checkreferer) {         if ($checkreferer) {
   my $refuri=$ENV{'httpref.'.$orguri};    my $refuri=$ENV{'httpref.'.$orguri};
   
             unless ($refuri) {              unless ($refuri) {
                 foreach (keys %ENV) {                  foreach (keys %ENV) {
     if ($_=~/^httpref\..*\*/) {      if ($_=~/^httpref\..*\*/) {
Line 1580  sub allowed { Line 1581  sub allowed {
                     }                      }
                 }                  }
             }              }
   
          if ($refuri) {            if ($refuri) { 
   $refuri=&declutter($refuri);    $refuri=&declutter($refuri);
           my @uriparts=split(/\//,$refuri);            my ($match,$cond)=&is_on_map($refuri);
           my $filename=$uriparts[$#uriparts];              if ($match) {
           my $pathname=$refuri;                my $refstatecond=$cond;
           $pathname=~s/\/$filename$//;  
             if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~  
               /\&$filename\:([\d\|]+)\&/) {  
               my $refstatecond=$1;  
               if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}                if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
                   =~/$priv\&([^\:]*)/) {                    =~/$priv\&([^\:]*)/) {
                   $thisallowed.=$1;                    $thisallowed.=$1;
Line 1686  sub allowed { Line 1684  sub allowed {
   
    if ($thisallowed=~/C/) {     if ($thisallowed=~/C/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
          my $unamedom=$ENV{'user.name'}.':'.$ENV{'user.domain'};
        if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}         if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
    =~/$rolecode/) {     =~/$rolecode/) {
            &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},             &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
Line 1693  sub allowed { Line 1692  sub allowed {
                 $ENV{'request.course.id'});                  $ENV{'request.course.id'});
            return '';             return '';
        }         }
   
          if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.users.denied'}
      =~/$unamedom/) {
              &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
                   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
                   $ENV{'request.course.id'});
              return '';
          }
    }     }
   
 # Resource preferences  # Resource preferences
Line 1729  sub allowed { Line 1736  sub allowed {
    return 'F';     return 'F';
 }  }
   
   # --------------------------------------------------- Is a resource on the map?
   
   sub is_on_map {
       my $uri=&declutter(shift);
       my @uriparts=split(/\//,$uri);
       my $filename=$uriparts[$#uriparts];
       my $pathname=$uri;
       $pathname=~s/\/$filename$//;
       my $match=($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
          /\&$filename\:([\d\|]+)\&/);
       if ($match) {
          return (1,$1);
      } else {
          return (0,0);
      }
   }
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
   
 sub definerole {  sub definerole {
Line 1875  sub modifyuser { Line 1899  sub modifyuser {
              (defined($desiredhome) ? ' desiredhome = '.$desiredhome :               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                      ' desiredhome not specified').                                        ' desiredhome not specified'). 
              ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});               ' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom,'true');
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') && ($umode) && ($upass)) {      if (($uhome eq 'no_host') && ($umode) && ($upass)) {
         my $unhome='';          my $unhome='';
Line 1905  sub modifyuser { Line 1929  sub modifyuser {
  unless ($reply eq 'ok') {   unless ($reply eq 'ok') {
             return 'error: '.$reply;              return 'error: '.$reply;
         }             }   
         $uhome=&homeserver($uname,$udom);          $uhome=&homeserver($uname,$udom,'true');
         if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {          if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
     return 'error: verify home';      return 'error: verify home';
         }          }
Line 2012  sub createcourse { Line 2036  sub createcourse {
    my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).     my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
 # ----------------------------------------------- Make sure that does not exist  # ----------------------------------------------- Make sure that does not exist
    my $uhome=&homeserver($uname,$udom);     my $uhome=&homeserver($uname,$udom,'true');
    unless (($uhome eq '') || ($uhome eq 'no_host')) {     unless (($uhome eq '') || ($uhome eq 'no_host')) {
        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).         $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};          unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
        $uhome=&homeserver($uname,$udom);                $uhome=&homeserver($uname,$udom,'true');       
        unless (($uhome eq '') || ($uhome eq 'no_host')) {         unless (($uhome eq '') || ($uhome eq 'no_host')) {
            return 'error: unable to generate unique course-ID';             return 'error: unable to generate unique course-ID';
        }          } 
Line 2025  sub createcourse { Line 2049  sub createcourse {
     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                       $ENV{'user.home'});                        $ENV{'user.home'});
     unless ($reply eq 'ok') { return 'error: '.$reply; }      unless ($reply eq 'ok') { return 'error: '.$reply; }
     $uhome=&homeserver($uname,$udom);      $uhome=&homeserver($uname,$udom,'true');
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   return 'error: no such course';
     }      }
Line 2263  sub EXT { Line 2287  sub EXT {
             my %reply=&get($space,[$item]);              my %reply=&get($space,[$item]);
             return $reply{$item};              return $reply{$item};
         }          }
     } elsif ($realm eq 'request') {      } elsif ($realm eq 'query') {
   # ---------------------------------------------- pull stuff out of query string
           &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},[$space]);
    return $ENV{'form.'.$space}; 
      } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     return $ENV{'browser.'.$qualifier};      return $ENV{'browser.'.$qualifier};
Line 2758  sub hreflocation { Line 2786  sub hreflocation {
     unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {      unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
        my $finalpath=filelocation($dir,$file);         my $finalpath=filelocation($dir,$file);
        $finalpath=~s/^\/home\/httpd\/html//;         $finalpath=~s/^\/home\/httpd\/html//;
          $finalpath=~s-/home/(\w+)/public_html/-/~$1/-;
        return $finalpath;         return $finalpath;
     } else {      } else {
        return $file;         return $file;
Line 2771  sub declutter { Line 2800  sub declutter {
     $thisfn=~s/^$perlvar{'lonDocRoot'}//;      $thisfn=~s/^$perlvar{'lonDocRoot'}//;
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
       $thisfn=~s/\?.+$//;
     return $thisfn;      return $thisfn;
 }  }
   
Line 2799  sub goodbye { Line 2829  sub goodbye {
 }  }
   
 BEGIN {  BEGIN {
 # ------------------------------------------- Read access.conf and loncapa.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
 # (eventually access.conf will become deprecated)  
     unless ($readit) {      unless ($readit) {
   
 {  {
     my $config=Apache::File->new("/etc/httpd/conf/access.conf");      my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
         if ($configline =~ /^[^\#]*PerlSetVar/) {          if ($configline =~ /^[^\#]*PerlSetVar/) {
Line 2815  BEGIN { Line 2843  BEGIN {
     }      }
 }  }
 {  {
     my $config=Apache::File->new("/etc/httpd/conf/loncapa.conf");      my $config=Apache::File->new("/etc/httpd/conf/loncapa_apache.conf");
   
     while (my $configline=<$config>) {      while (my $configline=<$config>) {
         if ($configline =~ /^[^\#]*PerlSetVar/) {          if ($configline =~ /^[^\#]*PerlSetVar/) {
Line 3287  replicates and subscribes to the file Line 3315  replicates and subscribes to the file
 =item *  =item *
   
 filelocation($dir,$file) : returns file system location of a file based on URI;  filelocation($dir,$file) : returns file system location of a file based on URI;
 meant to be "fairly clean" absolute reference  meant to be "fairly clean" absolute reference, $dir is a directory that relative $file lookups are to looked in ($dir of /a/dir and a file of ../bob will become /a/bob)
   
 =item *  =item *
   
Removed from v.1.219  
changed lines
  Added in v.1.237

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