[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.682 and 1.689

version 1.682, 2005/11/21 19:08:29 version 1.689, 2006/01/05 19:40:31
Line 40  qw(%perlvar %hostname %badServerCache %i Line 40  qw(%perlvar %hostname %badServerCache %i
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount      %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount 
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf     %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf
    %domaindescription %domain_auth_def %domain_auth_arg_def      %domaindescription %domain_auth_def %domain_auth_arg_def 
    %domain_lang_def %domain_city %domain_longi %domain_lati $tmpdir $_64bit     %domain_lang_def %domain_city %domain_longi %domain_lati %domain_primary
    %env);     $tmpdir $_64bit %env);
   
 use IO::Socket;  use IO::Socket;
 use GDBM_File;  use GDBM_File;
Line 1280  sub clean_filename { Line 1280  sub clean_filename {
 }  }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: name of form element, coursedoc=1 means this is for the course  # input: $formname - the contents of the file are in $env{"form.$formname"}
 # output: url of file in userspace  #                    the desired filenam is in $env{"form.$formname"}
   #        $coursedoc - if true up to the current course
   #                     if false
   #        $subdir - directory in userfile to store the file into
   #        $parser, $allfiles, $codebase - unknown
   #
   # output: url of file in userspace, or error: <message> 
   #             or /adm/notfound.html if failure to upload occurse
   
   
 sub userfileupload {  sub userfileupload {
Line 1853  sub courseiddump { Line 1860  sub courseiddump {
 # ---------------------------------------------------------- DC e-mail  # ---------------------------------------------------------- DC e-mail
   
 sub dcmailput {  sub dcmailput {
     my ($domain,$msgid,$contents,$server)=@_;      my ($domain,$msgid,$message,$server)=@_;
     my $status = &Apache::lonnet::critical(      my $status = &Apache::lonnet::critical(
        'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.         'dcmailput:'.$domain.':'.&Apache::lonnet::escape($msgid).'='.
        &Apache::lonnet::escape($$contents{$server}),$server);         &Apache::lonnet::escape($message),$server);
     return $status;      return $status;
 }  }
   
 sub dcmaildump {  sub dcmaildump {
     my ($dom,$startdate,$enddate,$senders) = @_;      my ($dom,$startdate,$enddate,$senders) = @_;
     my %returnhash=();       my %returnhash=();
     foreach my $tryserver (keys(%libserv)) {      if (exists($domain_primary{$dom})) {
         if ($hostdom{$tryserver} eq $dom) {          my $cmd='dcmaildump:'.$dom.':'.&escape($startdate).':'.
             %{$returnhash{$tryserver}}=();                                                           &escape($enddate).':';
     my $cmd='dcmaildump:'.$dom.':'.   my @esc_senders=map { &escape($_)} @$senders;
  &escape($startdate).':'.&escape($enddate).':';   $cmd.=&escape(join('&',@esc_senders));
     my @esc_senders=map { &escape($_)} @$senders;   foreach (split(/\&/,&reply($cmd,$domain_primary{$dom}))) {
     $cmd.=&escape(join('&',@esc_senders));              my ($key,$value) = split(/\=/,$_);
     foreach (split(/\&/,&reply($cmd,$tryserver))) {              if (($key) && ($value)) {
                 my ($key,$value) = split(/\=/,$_);                  $returnhash{&unescape($key)} = &unescape($value);
                 if (($key) && ($value)) {  
                     $returnhash{$tryserver}{&unescape($key)} = &unescape($value);  
                 }  
             }              }
         }          }
     }      }
Line 3013  sub tmpput { Line 3017  sub tmpput {
   
 # ------------------------------------------------------------ tmpget interface  # ------------------------------------------------------------ tmpget interface
 sub tmpget {  sub tmpget {
     my ($token)=@_;      my ($token,$server)=@_;
     my $rep=&reply("tmpget:$token",$perlvar{'lonHostID'});      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
       my $rep=&reply("tmpget:$token",$server);
     my %returnhash;      my %returnhash;
     foreach my $item (split(/\&/,$rep)) {      foreach my $item (split(/\&/,$rep)) {
  my ($key,$value)=split(/=/,$item);   my ($key,$value)=split(/=/,$item);
Line 3023  sub tmpget { Line 3028  sub tmpget {
     return %returnhash;      return %returnhash;
 }  }
   
   # ------------------------------------------------------------ tmpget interface
   sub tmpdel {
       my ($token,$server)=@_;
       if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
       return &reply("tmpdel:$token",$server);
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
 sub customaccess {  sub customaccess {
Line 3341  sub allowed { Line 3353  sub allowed {
        my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};         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'}
    =~/\Q$rolecode\E/) {     =~/\Q$rolecode\E/) {
            &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.     if ($priv ne 'pch') { 
                 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
                 $env{'request.course.id'});   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
    $env{'request.course.id'});
      }
            return '';             return '';
        }         }
   
        if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
    =~/\Q$unamedom\E/) {     =~/\Q$unamedom\E/) {
            &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.     if ($priv ne 'pch') { 
                 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
                 $env{'request.course.id'});   'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
    $env{'request.course.id'});
      }
            return '';             return '';
        }         }
    }     }
Line 3361  sub allowed { Line 3377  sub allowed {
    if ($thisallowed=~/R/) {     if ($thisallowed=~/R/) {
        my $rolecode=(split(/\./,$env{'request.role'}))[0];         my $rolecode=(split(/\./,$env{'request.role'}))[0];
        if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {         if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
    &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.     if ($priv ne 'pch') { 
  'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);         &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
           return '';   'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
      }
      return '';
        }         }
    }     }
   
Line 3703  sub auto_instcode_format { Line 3721  sub auto_instcode_format {
 # ------------------------------------------------------- Course Group routines  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
     my ($cdom,$cnum,$curr_groups,$group) = @_;      my ($cdom,$cnum,$group) = @_;
     my $numgroups = 0;      return(&dump('coursegroups',$cdom,$cnum,$group));
     %{$curr_groups} = &dump('coursegroups',$cdom,$cnum,$group);  
     my ($tmp)=keys(%{$curr_groups});  
     if ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') {  
         my %emptyhash = ();  
         if (&put('coursegroups',\%emptyhash,$cdom,$cnum) eq 'ok') {  
             %{$curr_groups} = &dump('coursegroups',$cdom,$cnum,$group);  
             $tmp=keys(%{$curr_groups});  
         }  
     }  
     if ($tmp=~/^error:/) {  
         &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'.$cdom);  
     } else {  
         my @groups = keys(%{$curr_groups});  
         $numgroups = @groups;  
     }  
     return $numgroups;  
 }  }
   
 sub modify_coursegroup {  sub modify_coursegroup {
Line 3734  sub modify_group_roles { Line 3736  sub modify_group_roles {
     my $role = 'gr/'.&escape($userprivs);      my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);      my ($uname,$udom) = split(/:/,$user);
     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);      my $result = &assignrole($udom,$uname,$url,$role,$end,$start);
       if ($result eq 'ok') {
           &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
       }
   
     return $result;      return $result;
 }  }
   
Line 3760  sub get_active_groups { Line 3766  sub get_active_groups {
     return %groups;      return %groups;
 }  }
   
   sub get_group_membership {
       my ($cdom,$cnum,$group) = @_;
       return(&dump('groupmembership',$cdom,$cnum,$group));
   }
   
   sub get_users_groups {
       my ($udom,$uname,$courseid) = @_;
       my $cachetime=1800;
       $courseid=~s/\_/\//g;
       $courseid=~s/^(\w)/\/$1/;
   
       my $hashid="$udom:$uname:$courseid";
       my ($result,$cached)=&is_cached_new('getgroups',$hashid);
       if (defined($cached)) { return $result; }
   
       my %roleshash = &dump('roles',$udom,$uname,$courseid);
       my ($tmp) = keys(%roleshash);
       if ($tmp=~/^error:/) {
           &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);
           return '';
       } else {
           my $grouplist;
           foreach my $key (keys %roleshash) {
               if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {
                   unless ($roleshash{$key} =~ /_1_1$/) {   # deleted membership
                       $grouplist .= $1.':';
                   }
               }
           }
           $grouplist =~ s/:$//;
           return &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
       }
   }
   
   sub devalidate_getgroups_cache {
       my ($udom,$uname,$cdom,$cnum)=@_;
       my $courseid = $cdom.'_'.$cnum;
       $courseid=~s/\_/\//g;
       $courseid=~s/^(\w)/\/$1/;
       my $hashid="$udom:$uname:$courseid";
       &devalidate_cache_new('getgroups',$hashid);
   }
   
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
Line 4774  sub EXT { Line 4823  sub EXT {
         return $env{'course.'.$courseid.'.'.$spacequalifierrest};          return $env{'course.'.$courseid.'.'.$spacequalifierrest};
     } elsif ($realm eq 'resource') {      } elsif ($realm eq 'resource') {
   
  my $section;   my ($section,$group);
           my @groups = ();
  if (defined($courseid) && $courseid eq $env{'request.course.id'}) {   if (defined($courseid) && $courseid eq $env{'request.course.id'}) {
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
  }   }
Line 4794  sub EXT { Line 4844  sub EXT {
     if (($env{'user.name'} eq $uname) &&      if (($env{'user.name'} eq $uname) &&
  ($env{'user.domain'} eq $udom)) {   ($env{'user.domain'} eq $udom)) {
  $section=$env{'request.course.sec'};   $section=$env{'request.course.sec'};
                   @groups=split(/:/,$env{'request.course.groups'});
                   if (@groups > 0) {
                       @groups = sort(@groups);
                       $group = $groups[0];
                   }
     } else {      } else {
  if (! defined($usection)) {   if (! defined($usection)) {
     $section=&getsection($udom,$uname,$courseid);      $section=&getsection($udom,$uname,$courseid);
  } else {   } else {
     $section = $usection;      $section = $usection;
  }   }
                   my $grouplist = &get_users_groups($udom,$uname,$courseid);
                   if ($grouplist) {
                       @groups = split(/:/,$grouplist);
                       @groups = sort(@groups);
                       $group = $groups[0];
                   }
     }      }
   
               my $grplevel=$courseid.'.['.$group.'].'.$spacequalifierrest;
               my $grplevelr=$courseid.'.['.$group.'].'.$symbparm;
               my $grplevelm=$courseid.'.['.$group.'].'.$mapparm;
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
     my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;      my $seclevelr=$courseid.'.['.$section.'].'.$symbparm;
     my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;      my $seclevelm=$courseid.'.['.$section.'].'.$mapparm;
Line 4819  sub EXT { Line 4884  sub EXT {
     if (defined($userreply)) { return $userreply; }      if (defined($userreply)) { return $userreply; }
   
 # ------------------------------------------------ second, check some of course  # ------------------------------------------------ second, check some of course
               my $coursereply;
               if (defined($group)) {
                   $coursereply = &resdata($env{'course.'.$courseid.'.num'},
                                        $env{'course.'.$courseid.'.domain'},
                                        'course',
                                        ($grplevelr,$grplevelm,$grplevel,
                                         $courselevelr));
                   if (defined($coursereply)) { return $coursereply; }
               }
   
     my $coursereply=&resdata($env{'course.'.$courseid.'.num'},      $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},       $env{'course.'.$courseid.'.domain'},
      'course',       'course',
      ($seclevelr,$seclevelm,$seclevel,       ($seclevelr,$seclevelm,$seclevel,
Line 5385  sub symbread { Line 5459  sub symbread {
         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {          if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
             $targetfn = 'adm/wrapper/'.$thisfn;              $targetfn = 'adm/wrapper/'.$thisfn;
         }          }
    if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
       $targetfn=$1;
    }
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                       &GDBM_READER(),0640)) {                        &GDBM_READER(),0640)) {
     $syval=$hash{$targetfn};      $syval=$hash{$targetfn};
Line 6158  BEGIN { Line 6235  BEGIN {
 #           next if /^\#/;  #           next if /^\#/;
            chomp;             chomp;
            my ($domain, $domain_description, $def_auth, $def_auth_arg,             my ($domain, $domain_description, $def_auth, $def_auth_arg,
        $def_lang, $city, $longi, $lati) = split(/:/,$_);         $def_lang, $city, $longi, $lati, $primary) = split(/:/,$_);
    $domain_auth_def{$domain}=$def_auth;     $domain_auth_def{$domain}=$def_auth;
            $domain_auth_arg_def{$domain}=$def_auth_arg;             $domain_auth_arg_def{$domain}=$def_auth_arg;
    $domaindescription{$domain}=$domain_description;     $domaindescription{$domain}=$domain_description;
Line 6166  BEGIN { Line 6243  BEGIN {
    $domain_city{$domain}=$city;     $domain_city{$domain}=$city;
    $domain_longi{$domain}=$longi;     $domain_longi{$domain}=$longi;
    $domain_lati{$domain}=$lati;     $domain_lati{$domain}=$lati;
              $domain_primary{$domain}=$primary;
   
  #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");   #         &logthis("Domain.tab: $domain, $domain_auth_def{$domain}, $domain_auth_arg_def{$domain},$domaindescription{$domain}");
 #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );  #          &logthis("Domain.tab: $domain ".$domaindescription{$domain} );
Removed from v.1.682  
changed lines
  Added in v.1.689

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