[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.215 and 1.234

version 1.215, 2002/05/08 15:21:04 version 1.234, 2002/05/27 19:03:59
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 1729  sub allowed { Line 1727  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 {
Line 1875  sub modifyuser { Line 1891  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 1921  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 2028  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 2041  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 2196  sub courseresdata { Line 2212  sub courseresdata {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
   
 sub EXT {  sub EXT {
     my ($varname,$symbparm)=@_;      my ($varname,$symbparm,$udom,$uname)=@_;
   
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
   
       #get real user name/domain, courseid and symb
       my $courseid;
       if (!($uname && $udom)) {
         (my $cursymb,$courseid,$udom,$uname)=&Apache::lonxml::whichuser();
         if (!$symbparm) { $symbparm=$cursymb; }
       } else {
    $courseid=$ENV{'request.course.id'};
       }
   
     my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);      my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
     my $rest;      my $rest;
     if ($therest[0]) {      if ($therest[0]) {
Line 2212  sub EXT { Line 2239  sub EXT {
     if ($realm eq 'user') {      if ($realm eq 'user') {
 # --------------------------------------------------------------- user.resource  # --------------------------------------------------------------- user.resource
  if ($space eq 'resource') {   if ($space eq 'resource') {
     my %restored=&restore();      my %restored=&restore(undef,undef,$udom,$uname);
             return $restored{$qualifierrest};              return $restored{$qualifierrest};
 # ----------------------------------------------------------------- user.access  # ----------------------------------------------------------------- user.access
         } elsif ($space eq 'access') {          } elsif ($space eq 'access') {
       # FIXME - not supporting calls for a specific user
             return &allowed($qualifier,$rest);              return &allowed($qualifier,$rest);
 # ------------------------------------------ user.preferences, user.environment  # ------------------------------------------ user.preferences, user.environment
         } elsif (($space eq 'preferences') || ($space eq 'environment')) {          } elsif (($space eq 'preferences') || ($space eq 'environment')) {
             return $ENV{join('.',('environment',$qualifierrest))};      if (($uname eq $ENV{'user.name'}) &&
    ($udom eq $ENV{'user.domain'})) {
    return $ENV{join('.',('environment',$qualifierrest))};
       } else {
    my %returnhash=&userenvironment($udom,$uname,$qualifierrest);
    return $returnhash{$qualifierrest};
       }
 # ----------------------------------------------------------------- user.course  # ----------------------------------------------------------------- user.course
         } elsif ($space eq 'course') {          } elsif ($space eq 'course') {
       # FIXME - not supporting calls for a specific user
             return $ENV{join('.',('request.course',$qualifier))};              return $ENV{join('.',('request.course',$qualifier))};
 # ------------------------------------------------------------------- user.role  # ------------------------------------------------------------------- user.role
         } elsif ($space eq 'role') {          } elsif ($space eq 'role') {
       # FIXME - not supporting calls for a specific user
             my ($role,$where)=split(/\./,$ENV{'request.role'});              my ($role,$where)=split(/\./,$ENV{'request.role'});
             if ($qualifier eq 'value') {              if ($qualifier eq 'value') {
  return $role;   return $role;
Line 2233  sub EXT { Line 2269  sub EXT {
             }              }
 # ----------------------------------------------------------------- user.domain  # ----------------------------------------------------------------- user.domain
         } elsif ($space eq 'domain') {          } elsif ($space eq 'domain') {
             return $ENV{'user.domain'};              return $udom;
 # ------------------------------------------------------------------- user.name  # ------------------------------------------------------------------- user.name
         } elsif ($space eq 'name') {          } elsif ($space eq 'name') {
             return $ENV{'user.name'};              return $uname;
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
         } else {          } else {
             my $item=($rest)?$qualifier.'.'.$rest:$qualifier;              my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
Line 2253  sub EXT { Line 2289  sub EXT {
         }          }
     } elsif ($realm eq 'course') {      } elsif ($realm eq 'course') {
 # ---------------------------------------------------------- course.description  # ---------------------------------------------------------- course.description
         return $ENV{'course.'.$ENV{'request.course.id'}.'.'.          return $ENV{'course.'.$courseid.'.'.$spacequalifierrest};
                               $spacequalifierrest};  
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
        if ($ENV{'request.course.id'}) {  
   
 #   print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;   if ($courseid eq $ENV{'request.course.id'}) {
   
       #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
          my $symbp;      if (!$symbparm) { $symbparm=&symbread(); }
          if ($symbparm) {      my $symbp=$symbparm;
             $symbp=$symbparm;      my $mapp=(split(/\_\_\_/,$symbp))[0];
  } else {  
             $symbp=&symbread();      my $symbparm=$symbp.'.'.$spacequalifierrest;
          }                  my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
          my $mapp=(split(/\_\_\_/,$symbp))[0];  
       my $section;
          my $symbparm=$symbp.'.'.$spacequalifierrest;      if (($ENV{'user.name'} eq $uname) &&
          my $mapparm=$mapp.'___(all).'.$spacequalifierrest;   ($ENV{'user.domain'} eq $udom)) {
    $section={'request.course.sec'};
          my $seclevel=      } else {
             $ENV{'request.course.id'}.'.['.   $section=&usection($udom,$uname,$courseid);
  $ENV{'request.course.sec'}.'].'.$spacequalifierrest;      }
          my $seclevelr=  
             $ENV{'request.course.id'}.'.['.  
  $ENV{'request.course.sec'}.'].'.$symbparm;  
          my $seclevelm=  
             $ENV{'request.course.id'}.'.['.  
  $ENV{'request.course.sec'}.'].'.$mapparm;  
   
          my $courselevel=  
             $ENV{'request.course.id'}.'.'.$spacequalifierrest;  
          my $courselevelr=  
             $ENV{'request.course.id'}.'.'.$symbparm;  
          my $courselevelm=  
             $ENV{'request.course.id'}.'.'.$mapparm;  
   
 # ----------------------------------------------------------- first, check user      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
          my %resourcedata=get('resourcedata',      my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
                            [$courselevelr,$courselevelm,$courselevel]);      my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
          if (($resourcedata{$courselevelr}!~/^error\:/) &&  
              ($resourcedata{$courselevelr}!~/^con_lost/)) {      my $courselevel=$courseid.'.'.$spacequalifierrest;
       my $courselevelr=$courseid.'.'.$symbparm;
          if ($resourcedata{$courselevelr}) {       my $courselevelm=$courseid.'.'.$mapparm;
             return $resourcedata{$courselevelr}; }  
          if ($resourcedata{$courselevelm}) {   
             return $resourcedata{$courselevelm}; }  
          if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }  
   
       } else {  # ----------------------------------------------------------- first, check user
   if ($resourcedata{$courselevelr}!~/No such file/) {      my %resourcedata=&get('resourcedata',
     &logthis("<font color=blue>WARNING:".    [$courselevelr,$courselevelm,$courselevel],
    " Trying to get resource data for ".$ENV{'user.name'}." at "   $udom,$uname);
                    .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.      if (($resourcedata{$courselevelr}!~/^error\:/) &&
                  "</font>");   ($resourcedata{$courselevelr}!~/^con_lost/)) {
   }  
       }   if ($resourcedata{$courselevelr}) {
       return $resourcedata{$courselevelr}; }
    if ($resourcedata{$courselevelm}) {
       return $resourcedata{$courselevelm}; }
    if ($resourcedata{$courselevel}) {
       return $resourcedata{$courselevel}; }
       } else {
    if ($resourcedata{$courselevelr}!~/No such file/) {
       &logthis("<font color=blue>WARNING:".
        " Trying to get resource data for ".
        $uname." at ".$udom.": ".
        $resourcedata{$courselevelr}."</font>");
    }
       }
   
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
   
         my $coursereply=&courseresdata(      my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
                         $ENV{'course.'.$ENV{'request.course.id'}.'.num'},    $ENV{'course.'.$courseid.'.domain'},
                         $ENV{'course.'.$ENV{'request.course.id'}.'.domain'},    ($seclevelr,$seclevelm,$seclevel,
                         ($seclevelr,$seclevelm,$seclevel,     $courselevelr,$courselevelm,
                          $courselevelr,$courselevelm,$courselevel));     $courselevel));
         if ($coursereply) { return $coursereply; }      if ($coursereply) { return $coursereply; }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
        my %parmhash=();      my %parmhash=();
        my $thisparm='';             my $thisparm='';
        if (tie(%parmhash,'GDBM_File',      if (tie(%parmhash,'GDBM_File',
           $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {      $ENV{'request.course.fn'}.'_parms.db',
            $thisparm=$parmhash{$symbparm};      &GDBM_READER,0640)) {
    untie(%parmhash);   $thisparm=$parmhash{$symbparm};
        }   untie(%parmhash);
        if ($thisparm) { return $thisparm; }      }
      }      if ($thisparm) { return $thisparm; }
         }
 # --------------------------------------------- last, look in resource metadata  # --------------------------------------------- last, look in resource metadata
   
       $spacequalifierrest=~s/\./\_/;   $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'},   $metadata=&metadata($ENV{'request.filename'},
                                          'parameter_'.$spacequalifierrest);      'parameter_'.$spacequalifierrest);
       if ($metadata) { return $metadata; }   if ($metadata) { return $metadata; }
   
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
    unless ($space eq '0') {
       unless ($space eq '0') {      my ($part,$id)=split(/\_/,$space);
           my ($part,$id)=split(/\_/,$space);      if ($id) {
           if ($id) {   my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
       my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,       $symbparm,$udom,$uname);
                                    $symbparm);   if ($partgeneral) { return $partgeneral; }
               if ($partgeneral) { return $partgeneral; }      } else {
           } else {   my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
               my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,   $symbparm,$udom,$uname);
                                        $symbparm);   if ($resourcegeneral) { return $resourcegeneral; }
               if ($resourcegeneral) { return $resourcegeneral; }      }
           }   }
       }  
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
         return $ENV{'environment.'.$spacequalifierrest};   if (($uname eq $ENV{'user.name'})&&($udom eq $ENV{'user.domain'})) {
       return $ENV{'environment.'.$spacequalifierrest};
    } else {
       my %returnhash=&userenvironment($udom,$uname,
       $spacequalifierrest);
       return $returnhash{$spacequalifierrest};
    }
     } elsif ($realm eq 'system') {      } elsif ($realm eq 'system') {
 # ----------------------------------------------------------------- system.time  # ----------------------------------------------------------------- system.time
  if ($space eq 'time') {   if ($space eq 'time') {
Line 2524  sub symblist { Line 2560  sub symblist {
 sub symbverify {  sub symbverify {
     my ($symb,$thisfn)=@_;      my ($symb,$thisfn)=@_;
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
   
     &logthis("Symb verify: $symb $thisfn");  
   
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
     if ($thisfn=~/\.(page|sequence)$/) { return 1; }      if ($thisfn=~/\.(page|sequence)$/) { return 1; }
 # check URL part  # check URL part
     my ($map,$resid,$url)=split(/\_\_\_/,$symb);      my ($map,$resid,$url)=split(/\_\_\_/,$symb);
     unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }      unless (&symbclean($url) eq &symbclean($thisfn)) { return 0; }
   
 # FIXME: done for now      $symb=&symbclean($symb);
     return 1;  
   
     my %bighash;      my %bighash;
     my $okay=0;      my $okay=0;
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
                             &GDBM_READER,0640)) {                              &GDBM_READER,0640)) {
                   my $ids=$bighash{'ids_/res/'.$thisfn};
           unless ($ids) { 
              $ids=$bighash{'ids_/'.$thisfn};
           }
           if ($ids) {
   # ------------------------------------------------------------------- Has ID(s)
       foreach (split(/\,/,$ids)) {
                  my ($mapid,$resid)=split(/\./,$_);
                  if (
     &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
      eq $symb) { 
                     $okay=1; 
                  }
      }
           }
  untie(%bighash);   untie(%bighash);
     }      }
     return $okay;      return $okay;
Line 2728  sub hreflocation { Line 2774  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 2769  sub goodbye { Line 2816  sub goodbye {
 }  }
   
 BEGIN {  BEGIN {
 # ------------------------------------------------------------ Read access.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
     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>) {
           if ($configline =~ /^[^\#]*PerlSetVar/) {
      my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
              chomp($varvalue);
              $perlvar{$varname}=$varvalue;
           }
       }
   }
   {
       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/) {
    my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);     my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
            chomp($varvalue);             chomp($varvalue);
            $perlvar{$varname}=$varvalue;             $perlvar{$varname}=$varvalue;
Line 3244  replicates and subscribes to the file Line 3302  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.215  
changed lines
  Added in v.1.234

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