[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.336 and 1.346

version 1.336, 2003/03/07 23:45:31 version 1.346, 2003/03/23 01:46:51
Line 588  sub idput { Line 588  sub idput {
     }      }
 }  }
   
   # --------------------------------------------------- Assign a key to a student
   
   sub assign_access_key {
       my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       $udom=$ENV{'user.name'} unless (defined($udom));
       $uname=$ENV{'user.domain'} unless (defined($uname));
       my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
       if (($existing{$ckey}=~/^\d+$/) || # has time - new key
           ($existing{$ckey} eq $udom.':'.$uname)) { # this should not happen,
                                                     # unless something went wrong
                                                     # the first time around
   # ready to assign
       } elsif (!$existing{$ckey}) {
           if (&put('accesskey',{$ckey=>$udom.':'.$uname},$cdom,$cnum) eq 'ok') {
   # key now belongs to user
       my $envkey='key.'.$cdom.'_'.$cnum;
               if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                   &appenv('environment.'.$envkey => $ckey);
                   return 'ok';
               } else {
                   return 
     'error: Count not permanently assign key, will need to be re-entered later.';
       }
           } else {
               return 'error: Could not assign key, try again later.';
           }
   # the key does not exist
    return 'error: The key does not exist';
       } else {
   # the key is somebody else's
    return 'error: The key is already in use';
       }
   }
   
   # ------------------------------------------------------ Generate a set of keys
   
   sub generate_access_keys {
       my ($number,$cdom,$cnum)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       unless (&allowed('ccc',$cdom)) { return 0; }
       unless (($cdom) && ($cnum)) { return 0; }
       if ($number>10000) { return 0; }
       sleep(2); # make sure don't get same seed twice
       srand(time()^($$+($$<<15))); # from "Programming Perl"
       my $total=0;
       for (my $i=1;$i<=$number;$i++) {
          my $newkey=sprintf("%lx",int(100000*rand)).'-'.
                     sprintf("%lx",int(100000*rand)).'-'.
                     sprintf("%lx",int(100000*rand));
          $newkey=~s/1/g/g; # folks mix up 1 and l
          $newkey=~s/0/h/g; # and also 0 and O
          my %existing=&get('accesskeys',[$newkey],$cdom,$cnum);
          if ($existing{$newkey}) {
              $i--;
          } else {
     if (&put('accesskeys',{ $newkey => time() },$cdom,$cnum) eq 'ok') {
                 $total++;
     }
          }
       }
       &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.home'},
            'Generated '.$total.' keys for '.$cnum.' at '.$cdom);
       return $total;
   }
   
   # ------------------------------------------------------- Validate an accesskey
   
   sub validate_access_key {
       my ($ckey,$cdom,$cnum,$udom,$uname)=@_;
       $cdom=
      $ENV{'course.'.$ENV{'request.course.id'}.'.domain'} unless (defined($cdom));
       $cnum=
      $ENV{'course.'.$ENV{'request.course.id'}.'.num'} unless (defined($cnum));
       $udom=$ENV{'user.name'} unless (defined($udom));
       $uname=$ENV{'user.domain'} unless (defined($uname));
       my %existing=&get('accesskeys',[$ckey],$cdom,$cnum);
       return ($existing{$ckey} eq $udom.':'.$uname);
   }
   
 # ------------------------------------- Find the section of student in a course  # ------------------------------------- Find the section of student in a course
   
 sub getsection {  sub getsection {
Line 1870  sub eget { Line 1956  sub eget {
    return %returnhash;     return %returnhash;
 }  }
   
   # ---------------------------------------------- Custom access rule evaluation
   
   sub customaccess {
       my ($priv,$uri)=@_;
       my ($urole,$urealm)=split(/\./,$ENV{'request.role'});
       $urealm=~s/^\W//;
       my ($udom,$ucrs,$usec)=split(/\//,$urealm);
       my $access=0;
       foreach (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
    my ($effect,$realm,$role)=split(/\:/,$_);
           if ($role) {
      if ($role ne $urole) { next; }
           }
           foreach (split(/\s*\,\s*/,$realm)) {
               my ($tdom,$tcrs,$tsec)=split(/\_/,$_);
               if ($tdom) {
    if ($tdom ne $udom) { next; }
               }
               if ($tcrs) {
    if ($tcrs ne $ucrs) { next; }
               }
               if ($tsec) {
    if ($tsec ne $usec) { next; }
               }
               $access=($effect eq 'allow');
               last;
           }
       }
       return $access;
   }
   
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
Line 1908  sub allowed { Line 2025  sub allowed {
             # Library role, so allow browsing of resources in this domain.              # Library role, so allow browsing of resources in this domain.
             return 'F';              return 'F';
         }          }
           if ($copyright eq 'custom') {
       unless (&customaccess($priv,$uri)) { return ''; }
           }
     }      }
     # Domain coordinator is trying to create a course      # Domain coordinator is trying to create a course
     if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {      if (($priv eq 'ccc') && ($ENV{'request.role'} =~ /^dc\./)) {
Line 2125  sub allowed { Line 2245  sub allowed {
   
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$ENV{'request.role'}))[0];         my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
        my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';         if (&metadata($uri,'roledeny')=~/$rolecode/) {
        if (-e $filename) {    &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
            my @content;  
            {  
      my $fh=Apache::File->new($filename);  
              @content=<$fh>;  
    }  
            if (join('',@content)=~  
                     /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {  
        &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},  
                     'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);                      'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
            return '';            return '';
   
            }  
        }         }
    }     }
   
Line 3018  sub EXT { Line 3128  sub EXT {
     if ($part eq '') { $part='0'; }      if ($part eq '') { $part='0'; }
     my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,      my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
  $symbparm,$udom,$uname);   $symbparm,$udom,$uname);
       if (defined($partgeneral)) { return $partgeneral; }
  }   }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
Line 3088  sub metadata { Line 3199  sub metadata {
         my $token;          my $token;
         undef %metathesekeys;          undef %metathesekeys;
         while ($token=$parser->get_token) {          while ($token=$parser->get_token) {
            if ($token->[0] eq 'S') {      if ($token->[0] eq 'S') {
      if (defined($token->[2]->{'package'})) {   if (defined($token->[2]->{'package'})) {
 #  #
 # This is a package - get package info  # This is a package - get package info
 #  #
       my $package=$token->[2]->{'package'};      my $package=$token->[2]->{'package'};
       my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});      my $keyroot=&add_prefix_and_part($prefix,$token->[2]->{'part'});
               if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
                  $keyroot.='_'.$token->[2]->{'id'};    $keyroot.='_'.$token->[2]->{'id'}; 
       }      }
               if ($metacache{$uri.':packages'}) {      if ($metacache{$uri.':packages'}) {
                  $metacache{$uri.':packages'}.=','.$package.$keyroot;   $metacache{$uri.':packages'}.=','.$package.$keyroot;
               } else {      } else {
                  $metacache{$uri.':packages'}=$package.$keyroot;   $metacache{$uri.':packages'}=$package.$keyroot;
       }      }
               foreach (keys %packagetab) {      foreach (keys %packagetab) {
   if ($_=~/^$package\&/) {   if ($_=~/^$package\&/) {
       my ($pack,$name,$subp)=split(/\&/,$_);      my ($pack,$name,$subp)=split(/\&/,$_);
                       my $value=$packagetab{$_};      my $value=$packagetab{$_};
       my $part=$keyroot;      my $part=$keyroot;
                       $part=~s/^\_//;      $part=~s/^\_//;
                       if ($subp eq 'display') {      if ($subp eq 'display') {
   $value.=' [Part: '.$part.']';   $value.=' [Part: '.$part.']';
                       }      }
                       my $unikey='parameter'.$keyroot.'_'.$name;      my $unikey='parameter'.$keyroot.'_'.$name;
                       $metathesekeys{$unikey}=1;      if ($subp eq 'default') { $unikey='parameter_0_'.$name; }
                       $metacache{$uri.':'.$unikey.'.part'}=$part;      $metathesekeys{$unikey}=1;
                       unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {      $metacache{$uri.':'.$unikey.'.part'}=$part;
   $metacache{$uri.':'.$unikey.'.'.$subp}=$value;      unless (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
       }   $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
       if (defined($metacache{$uri.':'.$unikey.'.default'})) {      }
   $metacache{$uri.':'.$unikey}=      if (defined($metacache{$uri.':'.$unikey.'.default'})) {
      $metacache{$uri.':'.$unikey.'.default'}   $metacache{$uri.':'.$unikey}=
       }      $metacache{$uri.':'.$unikey.'.default'}
                   }   }
               }   }
              } else {      }
    } else {
 #  #
 # This is not a package - some other kind of start tag  # This is not a package - some other kind of start tag
 #   #
               my $entry=$token->[1];      my $entry=$token->[1];
               my $unikey;      my $unikey;
               if ($entry eq 'import') {      if ($entry eq 'import') {
                  $unikey='';   $unikey='';
               } else {      } else {
                  $unikey=$entry;   $unikey=$entry;
       }      }
       $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});      $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
   
               if (defined($token->[2]->{'id'})) {       if (defined($token->[2]->{'id'})) { 
                  $unikey.='_'.$token->[2]->{'id'};    $unikey.='_'.$token->[2]->{'id'}; 
       }      }
   
              if ($entry eq 'import') {      if ($entry eq 'import') {
 #  #
 # Importing a library here  # Importing a library here
 #                  #
                  if ($depthcount<20) {   if ($depthcount<20) {
      my $location=$parser->get_text('/import');      my $location=$parser->get_text('/import');
      my $dir=$filename;      my $dir=$filename;
      $dir=~s|[^/]*$||;      $dir=~s|[^/]*$||;
      $location=&filelocation($dir,$location);      $location=&filelocation($dir,$location);
      foreach (sort(split(/\,/,&metadata($uri,'keys',      foreach (sort(split(/\,/,&metadata($uri,'keys',
  $location,$unikey,         $location,$unikey,
  $depthcount+1)))) {         $depthcount+1)))) {
                          $metathesekeys{$_}=1;   $metathesekeys{$_}=1;
      }      }
  }   }
              } else {       } else { 
   
               if (defined($token->[2]->{'name'})) {    if (defined($token->[2]->{'name'})) { 
                  $unikey.='_'.$token->[2]->{'name'};       $unikey.='_'.$token->[2]->{'name'}; 
       }   }
               $metathesekeys{$unikey}=1;   $metathesekeys{$unikey}=1;
               foreach (@{$token->[3]}) {   foreach (@{$token->[3]}) {
   $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};      $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
               }   }
       my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));   my $internaltext=&HTML::Entities::decode($parser->get_text('/'.$entry));
       my $default=$metacache{$uri.':'.$unikey.'.default'};   my $default=$metacache{$uri.':'.$unikey.'.default'};
       if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {   if ( $internaltext =~ /^\s*$/ && $default !~ /^\s*$/) {
   # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
                   # as value   # as value
   $metacache{$uri.':'.$unikey}=$default;      $metacache{$uri.':'.$unikey}=$default;
       } else {   } else {
   # either something interesting inside the tag or default    # either something interesting inside the tag or default
                   # uninteresting                    # uninteresting
   $metacache{$uri.':'.$unikey}=$internaltext;      $metacache{$uri.':'.$unikey}=$internaltext;
       }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
    }      }
 # end of not-a-package start tag  # end of not-a-package start tag
   }   }
 # the next is the end of "start tag"  # the next is the end of "start tag"
  }      }
        }   }
        $metacache{$uri.':keys'}=join(',',keys %metathesekeys);  # are there custom rights to evaluate
    if ($metacache{$uri.':copyright'} eq 'custom') {
   
       #
       # Importing a rights file here
       #
       unless ($depthcount) {
    my $location=$metacache{$uri.':customdistributionfile'};
    my $dir=$filename;
    $dir=~s|[^/]*$||;
    $location=&filelocation($dir,$location);
    foreach (sort(split(/\,/,&metadata($uri,'keys',
      $location,'_rights',
      $depthcount+1)))) {
       $metathesekeys{$_}=1;
    }
       }
    }
    $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
  &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);   &metadata_generate_part0(\%metathesekeys,\%metacache,$uri);
        $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);   $metacache{$uri.':allpossiblekeys'}=join(',',keys %metathesekeys);
        $metacache{$uri.':cachedtimestamp'}=time;   $metacache{$uri.':cachedtimestamp'}=time;
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metacache{$uri.':'.$what};      return $metacache{$uri.':'.$what};
Removed from v.1.336  
changed lines
  Added in v.1.346

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