[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.822 and 1.829

version 1.822, 2007/01/11 21:09:10 version 1.829, 2007/01/18 21:31:40
Line 1176  sub repcopy { Line 1176  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 1701  sub removeuserfile { Line 1702  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 ($group,$file);      my $url = "/uploaded/$docudom/$docuname/$fname";
             if ($fname =~ /^groups\/(\w+)\/portfolio(\/.+)$/) {              my ($file,$group) = (&parse_portfolio_url($url))[3,4];
                 $group = $1;  
                 $file = $2;  
             } elsif ($fname =~ /^portfolio(\/.+)$/) {  
                 $file = $1;  
             }  
             my $sqlresult =               my $sqlresult = 
                 &update_portfolio_table($docuname,$docudom,$group.$file,                  &update_portfolio_table($docuname,$docudom,$file,
                                         'portfolio_metadata',$group,                                          'portfolio_metadata',$group,
                                         'delete');                                          'delete');
         }          }
Line 1734  sub renameuserfile { Line 1730  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 ($group,$file);      my $url = "/uploaded/$docudom/$docuname/$old";
             if ($old =~ /^groups\/(\w+)\/portfolio(\/.+)$/) {              my ($file,$group) = (&parse_portfolio_url($url))[3,4];
                 $group = $1;  
                 $file = $2;  
             } elsif ($old =~ /^portfolio(\/.+)$/) {  
                 $file = $1;  
             }  
             my $sqlresult =               my $sqlresult = 
                 &update_portfolio_table($docuname,$docudom,$group.$file,                  &update_portfolio_table($docuname,$docudom,$file,
                                         'portfolio_metadata',$group,                                          'portfolio_metadata',$group,
                                         'delete');                                          'delete');
         }          }
Line 3559  sub parse_portfolio_url { Line 3550  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 5326  sub modify_access_controls { Line 5317  sub modify_access_controls {
     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 7121  sub repcopy_userfile { Line 7159  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 7196  sub tokenwrapper { Line 7233  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 7312  sub current_machine_ids { Line 7353  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 7484  sub get_iphost { Line 7548  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);
Removed from v.1.822  
changed lines
  Added in v.1.829

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