--- loncom/lonnet/perl/lonnet.pm 2007/01/11 21:09:10 1.822 +++ loncom/lonnet/perl/lonnet.pm 2007/01/18 18:21:10 1.827 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.822 2007/01/11 21:09:10 albertel Exp $ +# $Id: lonnet.pm,v 1.827 2007/01/18 18:21:10 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -1701,15 +1701,10 @@ sub removeuserfile { if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { my $metafile = $fname.'.meta'; my $metaresult = &removeuserfile($docuname,$docudom,$metafile); - my ($group,$file); - if ($fname =~ /^groups\/(\w+)\/portfolio(\/.+)$/) { - $group = $1; - $file = $2; - } elsif ($fname =~ /^portfolio(\/.+)$/) { - $file = $1; - } + my $url = "/uploaded/$docudom/$docuname/$fname"; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; my $sqlresult = - &update_portfolio_table($docuname,$docudom,$group.$file, + &update_portfolio_table($docuname,$docudom,$file, 'portfolio_metadata',$group, 'delete'); } @@ -1734,15 +1729,10 @@ sub renameuserfile { my $newmeta = $new.'.meta'; my $metaresult = &renameuserfile($docuname,$docudom,$oldmeta,$newmeta); - my ($group,$file); - if ($old =~ /^groups\/(\w+)\/portfolio(\/.+)$/) { - $group = $1; - $file = $2; - } elsif ($old =~ /^portfolio(\/.+)$/) { - $file = $1; - } + my $url = "/uploaded/$docudom/$docuname/$old"; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; my $sqlresult = - &update_portfolio_table($docuname,$docudom,$group.$file, + &update_portfolio_table($docuname,$docudom,$file, 'portfolio_metadata',$group, 'delete'); } @@ -3559,12 +3549,12 @@ sub parse_portfolio_url { 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; $udom = $1; $unum = $2; $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; $udom = $1; $unum = $2; @@ -5326,6 +5316,53 @@ sub modify_access_controls { 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 sub get_marked_as_readonly { @@ -7153,6 +7190,10 @@ sub repcopy_userfile { if ($lwpresp ne 'ok') { my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',&tokenwrapper($uri)); + # FIXME, right reads everything into memory then writes it out + # doing something like + # my $response=$ua->request($request,$file); + # would make this write directly to disk my $response=$ua->request($request); if ($response->is_success()) { $info=$response->content; @@ -7312,6 +7353,29 @@ sub current_machine_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 (¤t_machine_domains(), + &additional_machine_domains()) { + if (lc($posdom) eq lc($testdomain)) { + $domain=$posdom; + last; + } + } + return $domain; +} + # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -7484,7 +7548,7 @@ sub get_iphost { if (!exists($name_to_ip{$name})) { $ip = gethostbyname($name); 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; } $ip=inet_ntoa($ip);