[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.809 and 1.824.2.3

version 1.809, 2006/11/28 19:46:00 version 1.824.2.3, 2007/03/17 04:13:06
Line 53  use Time::HiRes qw( gettimeofday tv_inte Line 53  use Time::HiRes qw( gettimeofday tv_inte
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
 use lib '/home/httpd/lib/perl';  
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
Line 368  sub transfer_profile_to_env { Line 367  sub transfer_profile_to_env {
     }      }
 }  }
   
   sub timed_flock {
       my ($file,$lock_type) = @_;
       my $failed=0;
       eval {
    local $SIG{__DIE__}='DEFAULT';
    local $SIG{ALRM}=sub {
       $failed=1;
       die("failed lock");
    };
    alarm(13);
    flock($file,$lock_type);
    alarm(0);
       };
       if ($failed) {
    return undef;
       } else {
    return 1;
       }
   }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
Line 382  sub appenv { Line 401  sub appenv {
             $env{$key}=$newenv{$key};              $env{$key}=$newenv{$key};
         }          }
     }      }
     if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),      open(my $env_file,$env{'user.environment'});
     0640)) {      if (&timed_flock($env_file,LOCK_EX)
    &&
    tie(my %disk_env,'GDBM_File',$env{'user.environment'},
       (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  while (my ($key,$value) = each(%newenv)) {   while (my ($key,$value) = each(%newenv)) {
     $disk_env{$key} = $value;      $disk_env{$key} = $value;
  }   }
Line 400  sub delenv { Line 422  sub delenv {
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
     if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),      open(my $env_file,$env{'user.environment'});
     0640)) {      if (&timed_flock($env_file,LOCK_EX)
    &&
    tie(my %disk_env,'GDBM_File',$env{'user.environment'},
       (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  foreach my $key (keys(%disk_env)) {   foreach my $key (keys(%disk_env)) {
     if ($key=~/^$delthis/) {       if ($key=~/^$delthis/) { 
                 delete($env{$key});                  delete($env{$key});
Line 878  sub devalidate_getsection_cache { Line 903  sub devalidate_getsection_cache {
     &devalidate_cache_new('getsection',$hashid);      &devalidate_cache_new('getsection',$hashid);
 }  }
   
   sub courseid_to_courseurl {
       my ($courseid) = @_;
       #already url style courseid
       return $courseid if ($courseid =~ m{^/});
   
       if (exists($env{'course.'.$courseid.'.num'})) {
    my $cnum = $env{'course.'.$courseid.'.num'};
    my $cdom = $env{'course.'.$courseid.'.domain'};
    return "/$cdom/$cnum";
       }
   
       my %courseinfo=&Apache::lonnet::coursedescription($courseid);
       if (exists($courseinfo{'num'})) {
    return "/$courseinfo{'domain'}/$courseinfo{'num'}";
       }
   
       return undef;
   }
   
 sub getsection {  sub getsection {
     my ($udom,$unam,$courseid)=@_;      my ($udom,$unam,$courseid)=@_;
     my $cachetime=1800;      my $cachetime=1800;
Line 901  sub getsection { Line 945  sub getsection {
     # If there is more than one expired role, choose the one which ended last.      # If there is more than one expired role, choose the one which ended last.
     # If there is a role which has expired, return it.      # If there is a role which has expired, return it.
     #      #
     foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',      $courseid = &courseid_to_courseurl($courseid);
  &homeserver($unam,$udom)))) {      my %roleshash = &dump('roles',$udom,$unam,$courseid);
         my ($key,$value)=split(/\=/,$line,2);      foreach my $key (keys(%roleshash)) {
         $key=&unescape($key);  
         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);          next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
         my $section=$1;          my $section=$1;
         if ($key eq $courseid.'_st') { $section=''; }          if ($key eq $courseid.'_st') { $section=''; }
         my ($dummy,$end,$start)=split(/\_/,&unescape($value));          my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key}));
         my $now=time;          my $now=time;
         if (defined($end) && $end && ($now > $end)) {          if (defined($end) && $end && ($now > $end)) {
             $Expired{$end}=$section;              $Expired{$end}=$section;
Line 947  my %remembered; Line 990  my %remembered;
 my %accessed;  my %accessed;
 my $kicks=0;  my $kicks=0;
 my $hits=0;  my $hits=0;
   sub make_key {
       my ($name,$id) = @_;
       if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }
       return &escape($name.':'.$id);
   }
   
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$id});      delete($remembered{$id});
     delete($accessed{$id});      delete($accessed{$id});
Line 958  sub devalidate_cache_new { Line 1007  sub devalidate_cache_new {
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     if (exists($remembered{$id})) {      if (exists($remembered{$id})) {
  if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }   if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
  $accessed{$id}=[&gettimeofday()];   $accessed{$id}=[&gettimeofday()];
Line 981  sub is_cached_new { Line 1030  sub is_cached_new {
   
 sub do_cache_new {  sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
     $id=&escape($name.':'.$id);      $id=&make_key($name,$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
  $setvalue='__undef__';   $setvalue='__undef__';
Line 1684  sub removeuserfile { Line 1733  sub removeuserfile {
         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {          if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
             my $metafile = $fname.'.meta';              my $metafile = $fname.'.meta';
             my $metaresult = &removeuserfile($docuname,$docudom,$metafile);               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
       my $url = "/uploaded/$docudom/$docuname/$fname";
               my ($file,$group) = (&parse_portfolio_url($url))[3,4];
               my $sqlresult = 
                   &update_portfolio_table($docuname,$docudom,$file,
                                           'portfolio_metadata',$group,
                                           'delete');
         }          }
     }      }
     return $result;      return $result;
Line 1706  sub renameuserfile { Line 1761  sub renameuserfile {
             my $newmeta = $new.'.meta';              my $newmeta = $new.'.meta';
             my $metaresult =               my $metaresult = 
                 &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);                  &renameuserfile($docuname,$docudom,$oldmeta,$newmeta);
       my $url = "/uploaded/$docudom/$docuname/$old";
               my ($file,$group) = (&parse_portfolio_url($url))[3,4];
               my $sqlresult = 
                   &update_portfolio_table($docuname,$docudom,$file,
                                           'portfolio_metadata',$group,
                                           'delete');
         }          }
     }      }
     return $result;      return $result;
Line 1772  sub flushcourselogs { Line 1833  sub flushcourselogs {
         if ($entry =~ /___count$/) {          if ($entry =~ /___count$/) {
             my ($dom,$name);              my ($dom,$name);
             ($dom,$name,undef)=              ($dom,$name,undef)=
  ($entry=~m{___($match_domain)/($match_username)/(.*)___count$});   ($entry=~m{___($match_domain)/($match_name)/(.*)___count$});
             if (! defined($dom) || $dom eq '' ||               if (! defined($dom) || $dom eq '' || 
                 ! defined($name) || $name eq '') {                  ! defined($name) || $name eq '') {
                 my $cid = $env{'request.course.id'};                  my $cid = $env{'request.course.id'};
Line 1793  sub flushcourselogs { Line 1854  sub flushcourselogs {
                 }                  }
             }              }
         } else {          } else {
             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_username)/(.*)___(\w+)$});              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
             my %temphash=($entry => $accesshash{$entry});              my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
Line 2732  sub coursedescription { Line 2793  sub coursedescription {
     if (!$args->{'one_time'}) {      if (!$args->{'one_time'}) {
  $envhash{'course.'.$normalid.'.last_cache'}=time;   $envhash{'course.'.$normalid.'.last_cache'}=time;
     }      }
   
     if ($chome ne 'no_host') {      if ($chome ne 'no_host') {
        %returnhash=&dump('environment',$cdomain,$cnum);         %returnhash=&dump('environment',$cdomain,$cnum);
        if (!exists($returnhash{'con_lost'})) {         if (!exists($returnhash{'con_lost'})) {
Line 2887  sub group_roleprivs { Line 2949  sub group_roleprivs {
     if (($tend!=0) && ($tend<$now)) { $access = 0; }      if (($tend!=0) && ($tend<$now)) { $access = 0; }
     if (($tstart!=0) && ($tstart>$now)) { $access=0; }      if (($tstart!=0) && ($tstart>$now)) { $access=0; }
     if ($access) {      if ($access) {
         my ($course,$group) = ($area =~ m|(/$match_domain/$match_username)/([^/]+)$|);          my ($course,$group) = ($area =~ m|(/$match_domain/$match_courseid)/([^/]+)$|);
         $$allgroups{$course}{$group} .=':'.$group_privs;          $$allgroups{$course}{$group} .=':'.$group_privs;
     }      }
 }  }
Line 2918  sub set_userprivs { Line 2980  sub set_userprivs {
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         foreach my $role (keys %{$allroles}) {          foreach my $role (keys %{$allroles}) {
             my ($trole,$area,$sec,$extendedarea);              my ($trole,$area,$sec,$extendedarea);
             if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_username)(/?\w*)-) {              if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {
                 $trole = $1;                  $trole = $1;
                 $area = $2;                  $area = $2;
                 $sec = $3;                  $sec = $3;
Line 3030  sub dump { Line 3092  sub dump {
   
 sub dumpstore {  sub dumpstore {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    return &dump($namespace,$udomain,$uname,$regexp,$range);     if (!$udomain) { $udomain=$env{'user.domain'}; }
      if (!$uname) { $uname=$env{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      if ($regexp) {
          $regexp=&escape($regexp);
      } else {
          $regexp='.';
      }
      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
      my @pairs=split(/\&/,$rep);
      my %returnhash=();
      foreach my $item (@pairs) {
          my ($key,$value)=split(/=/,$item,2);
          next if ($key =~ /^error: 2 /);
          $returnhash{$key}=&thaw_unescape($value);
      }
      return %returnhash;
 }  }
   
 # -------------------------------------------------------------- keys interface  # -------------------------------------------------------------- keys interface
Line 3043  sub getkeys { Line 3121  sub getkeys {
    my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);     my $rep=reply("keys:$udomain:$uname:$namespace",$uhome);
    my @keyarray=();     my @keyarray=();
    foreach my $key (split(/\&/,$rep)) {     foreach my $key (split(/\&/,$rep)) {
         next if ($key =~ /^error: 2 /);
       push(@keyarray,&unescape($key));        push(@keyarray,&unescape($key));
    }     }
    return @keyarray;     return @keyarray;
Line 3063  sub currentdump { Line 3142  sub currentdump {
    if ($rep eq "unknown_cmd") {      if ($rep eq "unknown_cmd") { 
        # an old lond will not know currentdump         # an old lond will not know currentdump
        # Do a dump and make it look like a currentdump         # Do a dump and make it look like a currentdump
        my @tmp = &dump($courseid,$sdom,$sname,'.');         my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
        return if ($tmp[0] =~ /^(error:|no_such_host)/);         return if ($tmp[0] =~ /^(error:|no_such_host)/);
        my %hash = @tmp;         my %hash = @tmp;
        @tmp=();         @tmp=();
Line 3088  sub convert_dump_to_currentdump{ Line 3167  sub convert_dump_to_currentdump{
     # we might run in to problems with parameter names =~ /^v\./      # we might run in to problems with parameter names =~ /^v\./
     while (my ($key,$value) = each(%hash)) {      while (my ($key,$value) = each(%hash)) {
         my ($v,$symb,$param) = split(/:/,$key);          my ($v,$symb,$param) = split(/:/,$key);
    $symb  = &unescape($symb);
    $param = &unescape($param);
         next if ($v eq 'version' || $symb eq 'keys');          next if ($v eq 'version' || $symb eq 'keys');
         next if (exists($returnhash{$symb}) &&          next if (exists($returnhash{$symb}) &&
                  exists($returnhash{$symb}->{$param}) &&                   exists($returnhash{$symb}->{$param}) &&
Line 3301  sub portfolio_access { Line 3382  sub portfolio_access {
     my ($requrl) = @_;      my ($requrl) = @_;
     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);      my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);      my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
       if ($result) {
           my %setters;
           if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
               my ($startblock,$endblock) =
                   &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
               if ($startblock && $endblock) {
                   return 'B';
               }
           } else {
               my ($startblock,$endblock) =
                   &Apache::loncommon::blockcheck(\%setters,'port');
               if ($startblock && $endblock) {
                   return 'B';
               }
           }
       }
     if ($result eq 'ok') {      if ($result eq 'ok') {
        return 'F';         return 'F';
     } elsif ($result =~ /^[^:]+:guest_/) {      } elsif ($result =~ /^[^:]+:guest_/) {
Line 3376  sub get_portfolio_access { Line 3473  sub get_portfolio_access {
                 my (%allgroups,%allroles);                   my (%allgroups,%allroles); 
                 my ($start,$end,$role,$sec,$group);                  my ($start,$end,$role,$sec,$group);
                 foreach my $envkey (%env) {                  foreach my $envkey (%env) {
                     if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_username)/?([^/]*)$-) {                      if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) {
                         my $cid = $2.'_'.$3;                           my $cid = $2.'_'.$3; 
                         if ($1 eq 'gr') {                          if ($1 eq 'gr') {
                             $group = $4;                              $group = $4;
Line 3389  sub get_portfolio_access { Line 3486  sub get_portfolio_access {
                             }                              }
                             $allroles{$cid}{$1}{$sec} = $env{$envkey};                              $allroles{$cid}{$1}{$sec} = $env{$envkey};
                         }                          }
                     } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_username)/?([^/]*)$-) {                      } elsif ($envkey =~ m-^user\.role\./cr/($match_domain/$match_username/\w*)./($match_domain)/($match_courseid)/?([^/]*)$-) {
                         my $cid = $2.'_'.$3;                          my $cid = $2.'_'.$3;
                         if ($4 eq '') {                          if ($4 eq '') {
                             $sec = 'none';                              $sec = 'none';
Line 3484  sub parse_portfolio_url { Line 3581  sub parse_portfolio_url {
   
     my ($type,$udom,$unum,$group,$file_name);      my ($type,$udom,$unum,$group,$file_name);
           
     if ($url =~  m-^/*uploaded/($match_domain)/($match_username)/portfolio(/.+)$-) {      if ($url =~  m-^/*(?:uploaded|editupload)/($match_domain)/($match_username)/portfolio(/.+)$-) {
  $type = 1;   $type = 1;
         $udom = $1;          $udom = $1;
         $unum = $2;          $unum = $2;
         $file_name = $3;          $file_name = $3;
     } elsif ($url =~ m-^/*uploaded/($match_domain)/($match_username)/groups/([^/]+)/portfolio/(.+)$-) {      } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) {
  $type = 2;   $type = 2;
         $udom = $1;          $udom = $1;
         $unum = $2;          $unum = $2;
Line 3509  sub is_portfolio_url { Line 3606  sub is_portfolio_url {
   
 sub is_portfolio_file {  sub is_portfolio_file {
     my ($file) = @_;      my ($file) = @_;
     if (($file =~ /^portfolio/) || ($file =~ /^groups\/$match_username\/portfolio/)) {      if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
         return 1;          return 1;
     }      }
     return;      return;
Line 3521  sub is_portfolio_file { Line 3618  sub is_portfolio_file {
 sub customaccess {  sub customaccess {
     my ($priv,$uri)=@_;      my ($priv,$uri)=@_;
     my ($urole,$urealm)=split(/\./,$env{'request.role'},2);      my ($urole,$urealm)=split(/\./,$env{'request.role'},2);
     my ($udom,$ucrs,$usec)=split(/\//,$urealm);      my (undef,$udom,$ucrs,$usec)=split(/\//,$urealm);
     $udom = &LONCAPA::clean_domain($udom);      $udom = &LONCAPA::clean_domain($udom);
     $ucrs = &LONCAPA::clean_username($ucrs);      $ucrs = &LONCAPA::clean_username($ucrs);
     my $access=0;      my $access=0;
Line 3554  sub customaccess { Line 3651  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb)=@_;      my ($priv,$uri,$symb,$role)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
       if ($priv eq 'evb') {
   # Evade communication block restrictions for specified role in a course
           if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
               return $1;
           } else {
               return;
           }
       }
   
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) 
Line 3572  sub allowed { Line 3678  sub allowed {
     my ($space,$domain,$name,@dir)=split('/',$uri);      my ($space,$domain,$name,@dir)=split('/',$uri);
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
         return 'F';          my %setters;
           my ($startblock,$endblock) = 
               &Apache::loncommon::blockcheck(\%setters,'port');
           if ($startblock && $endblock) {
               return 'B';
           } else {
               return 'F';
           }
     }      }
   
 # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.  # bre access to group portfolio for rgf priv in group, or mdg or vcg in course.
Line 3848  sub allowed { Line 3961  sub allowed {
     unless ($env{'request.course.id'}) {      unless ($env{'request.course.id'}) {
  if ($thisallowed eq 'A') {   if ($thisallowed eq 'A') {
     return 'A';      return 'A';
           } elsif ($thisallowed eq 'B') {
               return 'B';
  } else {   } else {
     return '1';      return '1';
  }   }
Line 3915  sub allowed { Line 4030  sub allowed {
   
     if ($thisallowed eq 'A') {      if ($thisallowed eq 'A') {
  return 'A';   return 'A';
       } elsif ($thisallowed eq 'B') {
           return 'B';
     }      }
    return 'F';     return 'F';
 }  }
Line 4041  sub log_query { Line 4158  sub log_query {
     return get_query_reply($queryid);      return get_query_reply($queryid);
 }  }
   
   # -------------------------- Update MySQL table for portfolio file
   
   sub update_portfolio_table {
       my ($uname,$udom,$file_name,$query,$group,$action) = @_;
       my $homeserver = &homeserver($uname,$udom);
       my $queryid=
           &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
                  ':'.&escape($file_name).':'.$action,$homeserver);
       my $reply = &get_query_reply($queryid);
       return $reply;
   }
   
 # ------- Request retrieval of institutional classlists for course(s)  # ------- Request retrieval of institutional classlists for course(s)
   
 sub fetch_enrollment_query {  sub fetch_enrollment_query {
Line 4428  sub get_active_groups { Line 4557  sub get_active_groups {
     my $now = time;      my $now = time;
     my %groups = ();      my %groups = ();
     foreach my $key (keys(%env)) {      foreach my $key (keys(%env)) {
         if ($key =~ m-user\.role\.gr\./($match_domain)/($match_username)/(\w+)$-) {          if ($key =~ m-user\.role\.gr\./($match_domain)/($match_courseid)/(\w+)$-) {
             my ($start,$end) = split(/\./,$env{$key});              my ($start,$end) = split(/\./,$env{$key});
             if (($end!=0) && ($end<$now)) { next; }              if (($end!=0) && ($end<$now)) { next; }
             if (($start!=0) && ($start>$now)) { next; }              if (($start!=0) && ($start>$now)) { next; }
Line 4456  sub get_users_groups { Line 4585  sub get_users_groups {
         @usersgroups = split(/:/,$grouplist);          @usersgroups = split(/:/,$grouplist);
     } else {        } else {  
         $grouplist = '';          $grouplist = '';
         my %roleshash = &dump('roles',$udom,$uname,$courseid);          my $courseurl = &courseid_to_courseurl($courseid);
         my ($tmp) = keys(%roleshash);          my %roleshash = &dump('roles',$udom,$uname,$courseurl);
         if ($tmp=~/^error:/) {          my $access_end = $env{'course.'.$courseid.
             &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom);                                '.default_enrollment_end_date'};
         } else {          my $now = time;
             my $access_end = $env{'course.'.$courseid.          foreach my $key (keys(%roleshash)) {
                                   '.default_enrollment_end_date'};              if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) {
             my $now = time;                  my $group = $1;
             foreach my $key (keys(%roleshash)) {                  if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {
                 if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) {                      my $start = $2;
                     my $group = $1;                      my $end = $1;
                     if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) {                      if ($start == -1) { next; } # deleted from group
                         my $start = $2;                      if (($start!=0) && ($start>$now)) { next; }
                         my $end = $1;                      if (($end!=0) && ($end<$now)) {
                         if ($start == -1) { next; } # deleted from group                          if ($access_end && $access_end < $now) {
                         if (($start!=0) && ($start>$now)) { next; }                              if ($access_end - $end < 86400) {
                         if (($end!=0) && ($end<$now)) {                                  push(@usersgroups,$group);
                             if ($access_end && $access_end < $now) {  
                                 if ($access_end - $end < 86400) {  
                                     push(@usersgroups,$group);  
                                 }  
                             }                              }
                             next;  
                         }                          }
                         push(@usersgroups,$group);                          next;
                     }                      }
                       push(@usersgroups,$group);
                 }                  }
             }              }
             @usersgroups = &sort_course_groups($courseid,@usersgroups);  
             $grouplist = join(':',@usersgroups);  
             &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);  
         }          }
           @usersgroups = &sort_course_groups($courseid,@usersgroups);
           $grouplist = join(':',@usersgroups);
           &do_cache_new('getgroups',$hashid,$grouplist,$cachetime);
     }      }
     return @usersgroups;      return @usersgroups;
 }  }
Line 4534  sub assignrole { Line 4659  sub assignrole {
     my $mrole;      my $mrole;
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
  unless (&allowed('ccr',$cwosec)) {   unless (&allowed('ccr',$cwosec)) {
            &logthis('Refused custom assignrole: '.             &logthis('Refused custom assignrole: '.
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 4544  sub assignrole { Line 4669  sub assignrole {
         $mrole='cr';          $mrole='cr';
     } elsif ($role =~ /^gr\//) {      } elsif ($role =~ /^gr\//) {
         my $cwogrp=$url;          my $cwogrp=$url;
         $cwogrp=~s{^/($match_domain)/($match_username)/.*}          $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2};
                   {$1/$2}x;  
         unless (&allowed('mdg',$cwogrp)) {          unless (&allowed('mdg',$cwogrp)) {
             &logthis('Refused group assignrole: '.              &logthis('Refused group assignrole: '.
               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.                $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 4555  sub assignrole { Line 4679  sub assignrole {
         $mrole='gr';          $mrole='gr';
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {           unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) { 
            &logthis('Refused assignrole: '.             &logthis('Refused assignrole: '.
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.               $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
Line 4921  ENDINITMAP Line 5045  ENDINITMAP
     return '/'.$udom.'/'.$uname;      return '/'.$udom.'/'.$uname;
 }  }
   
   sub is_course {
       my ($cdom,$cnum) = @_;
       my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
    undef,'.');
       if (exists($courses{$cdom.'_'.$cnum})) {
           return 1;
       }
       return 0;
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
Line 5199  sub modify_access_controls { Line 5333  sub modify_access_controls {
         #  remove lock          #  remove lock
         my @del_lock = ($file_name."\0".'locked_access_records');          my @del_lock = ($file_name."\0".'locked_access_records');
         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);          my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
           my ($file,$group);
           if (&is_course($domain,$user)) {
               ($group,$file) = split(/\//,$file_name,2);
           } else {
               $file = $file_name;
           }
           my $sqlresult =
               &update_portfolio_table($user,$domain,$file,'portfolio_access',
                                       $group);
     } else {      } else {
         $outcome = "error: could not obtain lockfile\n";            $outcome = "error: could not obtain lockfile\n";  
     }      }
Line 5434  sub stat_file { Line 5577  sub stat_file {
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file,$dir);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
     ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_username)/?(.*)-);      ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
  $file = 'userfiles/'.$file;   $file = 'userfiles/'.$file;
  $dir = &propath($udom,$uname);   $dir = &propath($udom,$uname);
     }      }
Line 6999  sub repcopy_userfile { Line 7142  sub repcopy_userfile {
     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }      if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_username)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
     my ($info,$rtncode);      my ($info,$rtncode);
     my $uri="/uploaded/$cdom/$cnum/$filename";      my $uri="/uploaded/$cdom/$cnum/$filename";
     if (-e "$file") {      if (-e "$file") {
Line 7030  sub repcopy_userfile { Line 7173  sub repcopy_userfile {
     } else {      } else {
  my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);   my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     my $ua=new LWP::UserAgent;      return -1;
     my $request=new HTTP::Request('GET',&tokenwrapper($uri));  
     my $response=$ua->request($request);  
     if ($response->is_success()) {  
  $info=$response->content;  
     } else {  
  return -1;  
     }  
  }   }
  my @parts = ($cdom,$cnum);    my @parts = ($cdom,$cnum); 
  if ($filename =~ m|^(.+)/[^/]+$|) {   if ($filename =~ m|^(.+)/[^/]+$|) {
Line 7121  sub filelocation { Line 7257  sub filelocation {
         $location = $file;          $location = $file;
     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
         my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
      ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_username)/+(.*)$-);       ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
         my $home=&homeserver($uname,$udom);          my $home=&homeserver($uname,$udom);
         my $is_me=0;          my $is_me=0;
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
Line 7161  sub hreflocation { Line 7297  sub hreflocation {
     } elsif ($file=~m-/home/($match_username)/public_html/-) {      } elsif ($file=~m-/home/($match_username)/public_html/-) {
  $file=~s-^/home/($match_username)/public_html/-/~$1/-;   $file=~s-^/home/($match_username)/public_html/-/~$1/-;
     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
  $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_username)/userfiles/   $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/
     -/uploaded/$1/$2/-x;      -/uploaded/$1/$2/-x;
     }      }
     return $file;      return $file;
Line 7191  sub current_machine_ids { Line 7327  sub current_machine_ids {
     return @ids;      return @ids;
 }  }
   
   sub additional_machine_domains {
       my @domains;
       open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
       while( my $line = <$fh>) {
           $line =~ s/\s//g;
           push(@domains,$line);
       }
       return @domains;
   }
   
   sub default_login_domain {
       my $domain = $perlvar{'lonDefDomain'};
       my $testdomain=(split(/\./,$ENV{'HTTP_HOST'}))[0];
       foreach my $posdom (&current_machine_domains(),
                           &additional_machine_domains()) {
           if (lc($posdom) eq lc($testdomain)) {
               $domain=$posdom;
               last;
           }
       }
       return $domain;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 7715  passed in @what from the requested user' Line 7874  passed in @what from the requested user'
   
 =item *  =item *
   
 allowed($priv,$uri,$symb) : check for a user privilege; returns codes for allowed actions  allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
  F: full access   F: full access
  U,I,K: authentication modes (cxx only)   U,I,K: authentication modes (cxx only)
  '': forbidden   '': forbidden
Removed from v.1.809  
changed lines
  Added in v.1.824.2.3

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