[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.814 and 1.832

version 1.814, 2006/12/11 14:06:05 version 1.832, 2007/02/16 01:04:19
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 1159  sub repcopy { Line 1202  sub repcopy {
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
   # FIXME: this should flock
     if ((-e $filename) || (-e $transname)) { return 'ok'; }      if ((-e $filename) || (-e $transname)) { return 'ok'; }
     my $remoteurl=subscribe($filename);      my $remoteurl=subscribe($filename);
     if ($remoteurl =~ /^con_lost by/) {      if ($remoteurl =~ /^con_lost by/) {
Line 1407  sub store_edited_file { Line 1451  sub store_edited_file {
 }  }
   
 sub clean_filename {  sub clean_filename {
     my ($fname)=@_;      my ($fname,$args)=@_;
 # Replace Windows backslashes by forward slashes  # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;      $fname=~s/\\/\//g;
 # Get rid of everything but the actual filename      if (!$args->{'keep_path'}) {
     $fname=~s/^.*\/([^\/]+)$/$1/;          # Get rid of everything but the actual filename
    $fname=~s/^.*\/([^\/]+)$/$1/;
       }
 # Replace spaces by underscores  # Replace spaces by underscores
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
 # Replace all other weird characters by nothing  # Replace all other weird characters by nothing
     $fname=~s/[^\w\.\-]//g;      $fname=~s{[^/\w\.\-]}{}g;
 # Replace all .\d. sequences with _\d. so they no longer look like version  # Replace all .\d. sequences with _\d. so they no longer look like version
 # numbers  # numbers
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
Line 1684  sub removeuserfile { Line 1730  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 1758  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 1969  sub get_course_adv_roles { Line 2027  sub get_course_adv_roles {
 }  }
   
 sub get_my_roles {  sub get_my_roles {
     my ($uname,$udom)=@_;      my ($uname,$udom,$types,$roles,$roledoms)=@_;
     unless (defined($uname)) { $uname=$env{'user.name'}; }      unless (defined($uname)) { $uname=$env{'user.name'}; }
     unless (defined($udom)) { $udom=$env{'user.domain'}; }      unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my %dumphash=      my %dumphash=
Line 1979  sub get_my_roles { Line 2037  sub get_my_roles {
     foreach my $entry (keys(%dumphash)) {      foreach my $entry (keys(%dumphash)) {
  my ($tend,$tstart)=split(/\:/,$dumphash{$entry});   my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
         if (($tend) && ($tend<$now)) { next; }          my $status = 'active';
         if (($tstart) && ($now<$tstart)) { next; }          if (($tend) && ($tend<$now)) {
               $status = 'previous';
           } 
           if (($tstart) && ($now<$tstart)) {
               $status = 'future';
           }
           if (ref($types) eq 'ARRAY') {
               if (!grep(/^\Q$status\E$/,@{$types})) {
                   next;
               } 
           } else {
               if ($status ne 'active') {
                   next;
               }
           }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($role,$username,$domain,$section)=split(/\:/,$entry);
           if (ref($roledoms) eq 'ARRAY') {
               if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
                   next;
               }
           }
           if (ref($roles) eq 'ARRAY') {
               if (!grep(/^\Q$role\E$/,@{$roles})) {
                   next;
               }
           } 
  $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;   $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
      }      }
     return %returnhash;      return %returnhash;
 }  }
   
Line 3031  sub dump { Line 3113  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 3065  sub currentdump { Line 3163  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 3090  sub convert_dump_to_currentdump{ Line 3188  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 3502  sub parse_portfolio_url { Line 3602  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_courseid)/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 3527  sub is_portfolio_url { Line 3627  sub is_portfolio_url {
   
 sub is_portfolio_file {  sub is_portfolio_file {
     my ($file) = @_;      my ($file) = @_;
     if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w\/portfolio/)) {      if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) {
         return 1;          return 1;
     }      }
     return;      return;
Line 3539  sub is_portfolio_file { Line 3639  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 4079  sub log_query { Line 4179  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 4494  sub get_users_groups { Line 4606  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 5246  sub modify_access_controls { Line 5354  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";  
     }      }
     return ($outcome,$deloutcome,\%new_values,\%translation);      return ($outcome,$deloutcome,\%new_values,\%translation);
 }  }
   
   sub make_public_indefinitely {
       my ($requrl) = @_;
       my $now = time;
       my $action = 'activate';
       my $aclnum = 0;
       if (&is_portfolio_url($requrl)) {
           my (undef,$udom,$unum,$file_name,$group) =
               &parse_portfolio_url($requrl);
           my $current_perms = &get_portfile_permissions($udom,$unum);
           my %access_controls = &get_access_controls($current_perms,
                                                      $group,$file_name);
           foreach my $key (keys(%{$access_controls{$file_name}})) {
               my ($num,$scope,$end,$start) = 
                   ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
               if ($scope eq 'public') {
                   if ($start <= $now && $end == 0) {
                       $action = 'none';
                   } else {
                       $action = 'update';
                       $aclnum = $num;
                   }
                   last;
               }
           }
           if ($action eq 'none') {
                return 'ok';
           } else {
               my %changes;
               my $newend = 0;
               my $newstart = $now;
               my $newkey = $aclnum.':public_'.$newend.'_'.$newstart;
               $changes{$action}{$newkey} = {
                   type => 'public',
                   time => {
                       start => $newstart,
                       end   => $newend,
                   },
               };
               my ($outcome,$deloutcome,$new_values,$translation) =
                   &modify_access_controls($file_name,\%changes,$udom,$unum);
               return $outcome;
           }
       } else {
           return 'invalid';
       }
   }
   
 #------------------------------------------------------Get Marked as Read Only  #------------------------------------------------------Get Marked as Read Only
   
 sub get_marked_as_readonly {  sub get_marked_as_readonly {
Line 7047  sub repcopy_userfile { Line 7211  sub repcopy_userfile {
     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_name)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
     my ($info,$rtncode);  
     my $uri="/uploaded/$cdom/$cnum/$filename";      my $uri="/uploaded/$cdom/$cnum/$filename";
     if (-e "$file") {      if (-e "$file") {
   # we already have a local copy, check it out
  my @fileinfo = stat($file);   my @fileinfo = stat($file);
    my $rtncode;
    my $info;
  my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);   my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
   # there is no such file anymore, even though we had a local copy
     if ($rtncode eq '404') {      if ($rtncode eq '404') {
  unlink($file);   unlink($file);
     }      }
     #my $ua=new LWP::UserAgent;  
     #my $request=new HTTP::Request('GET',&tokenwrapper($uri));  
     #my $response=$ua->request($request);  
     #if ($response->is_success()) {  
  # return $response->content;  
  #    } else {  
  # return -1;  
  #    }  
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
   # nice, the file we have is up-to-date, just say okay
     return 'ok';      return 'ok';
    } else {
   # the file is outdated, get rid of it
       unlink($file);
  }   }
  $info = '';      }
  $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);  # one way or the other, at this point, we don't have the file
  if ($lwpresp ne 'ok') {  # construct the correct path for the file
     return -1;      my @parts = ($cdom,$cnum); 
  }      if ($filename =~ m|^(.+)/[^/]+$|) {
     } else {   push @parts, split(/\//,$1);
  my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);      }
  if ($lwpresp ne 'ok') {      my $path = $perlvar{'lonDocRoot'}.'/userfiles';
     my $ua=new LWP::UserAgent;      foreach my $part (@parts) {
     my $request=new HTTP::Request('GET',&tokenwrapper($uri));   $path .= '/'.$part;
     my $response=$ua->request($request);   if (!-e $path) {
     if ($response->is_success()) {      mkdir($path,0770);
  $info=$response->content;  
     } else {  
  return -1;  
     }  
  }  
  my @parts = ($cdom,$cnum);   
  if ($filename =~ m|^(.+)/[^/]+$|) {  
     push @parts, split(/\//,$1);  
  }  
  my $path = $perlvar{'lonDocRoot'}.'/userfiles';  
  foreach my $part (@parts) {  
     $path .= '/'.$part;  
     if (!-e $path) {  
  mkdir($path,0770);  
     }  
  }   }
     }      }
     open(FILE,">$file");  # now the path exists for sure
     print FILE $info;  # get a user agent
     close(FILE);      my $ua=new LWP::UserAgent;
       my $transferfile=$file.'.in.transfer';
   # FIXME: this should flock
       if (-e $transferfile) { return 'ok'; }
       my $request;
       $uri=~s/^\///;
       $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
       my $response=$ua->request($request,$transferfile);
   # did it work?
       if ($response->is_error()) {
    unlink($transferfile);
    &logthis("Userfile repcopy failed for $uri");
    return -1;
       }
   # worked, rename the transfer file
       rename($transferfile,$file);
     return 'ok';      return 'ok';
 }  }
   
Line 7122  sub tokenwrapper { Line 7285  sub tokenwrapper {
     }      }
 }  }
   
   # call with reqtype HEAD: get last modification time
   # call with reqtype GET: get the file contents
   # Do not call this with reqtype GET for large files! It loads everything into memory
   #
 sub getuploaded {  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
Line 7238  sub current_machine_ids { Line 7405  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 7410  sub get_iphost { Line 7600  sub get_iphost {
  if (!exists($name_to_ip{$name})) {   if (!exists($name_to_ip{$name})) {
     $ip = gethostbyname($name);      $ip = gethostbyname($name);
     if (!$ip || length($ip) ne 4) {      if (!$ip || length($ip) ne 4) {
  &logthis("Skipping host $id name $name no IP found\n");   &logthis("Skipping host $id name $name no IP found");
  next;   next;
     }      }
     $ip=inet_ntoa($ip);      $ip=inet_ntoa($ip);
Line 7781  and course level Line 7971  and course level
 plaintext($short) : return value in %prp hash (rolesplain.tab); plain text  plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
 explanation of a user role term  explanation of a user role term
   
   =item *
   
   get_my_roles($uname,$udom,$types,$roles,$roledoms) : All arguments are optional.  Returns a hash of a user's roles, with keys set to colon-sparated $uname,$udom,and $role, and value set to colon-separated start and end times for the role. If no username and domain are specified, will default to current user/domain. Types, roles, and roledoms are references to arrays, of role statuses (active, future or previous), roles (e.g., cc,in, st etc.) and domains of the roles which can be used to restrict the list if roles reported. If no array ref is provided for types, will default to return only active roles.  
 =back  =back
   
 =head2 User Modification  =head2 User Modification
Removed from v.1.814  
changed lines
  Added in v.1.832

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