[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.231 and 1.233

version 1.231, 2002/05/22 13:56:43 version 1.233, 2002/05/23 21:24:13
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 1548  sub allowed { Line 1548  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 1570  sub allowed { Line 1567  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 1584  sub allowed { Line 1580  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 1733  sub allowed { Line 1726  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\|]+)\&/);
       &logthis('is: '.$uri.' '.$match.' '.$1);
       if ($match) {
          return (1,$1);
      } else {
          return (0,0);
      }
   }
   
 # ----------------------------------------------------------------- Define Role  # ----------------------------------------------------------------- Define Role
   
 sub definerole {  sub definerole {
Removed from v.1.231  
changed lines
  Added in v.1.233

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