--- loncom/lonnet/perl/lonnet.pm 2006/11/27 20:35:10 1.808 +++ loncom/lonnet/perl/lonnet.pm 2007/03/17 04:13:06 1.824.2.3 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.808 2006/11/27 20:35:10 albertel Exp $ +# $Id: lonnet.pm,v 1.824.2.3 2007/03/17 04:13:06 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -53,7 +53,6 @@ use Time::HiRes qw( gettimeofday tv_inte use Cache::Memcached; use Digest::MD5; use Math::Random; -use lib '/home/httpd/lib/perl'; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; @@ -368,6 +367,26 @@ 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 sub appenv { @@ -382,8 +401,11 @@ sub appenv { $env{$key}=$newenv{$key}; } } - if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), - 0640)) { + open(my $env_file,$env{'user.environment'}); + 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)) { $disk_env{$key} = $value; } @@ -400,8 +422,11 @@ sub delenv { "Attempt to delete from environment ".$delthis); return 'error'; } - if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(), - 0640)) { + open(my $env_file,$env{'user.environment'}); + 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)) { if ($key=~/^$delthis/) { delete($env{$key}); @@ -878,6 +903,25 @@ sub devalidate_getsection_cache { &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 { my ($udom,$unam,$courseid)=@_; my $cachetime=1800; @@ -901,14 +945,13 @@ sub getsection { # If there is more than one expired role, choose the one which ended last. # If there is a role which has expired, return it. # - foreach my $line (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles', - &homeserver($unam,$udom)))) { - my ($key,$value)=split(/\=/,$line,2); - $key=&unescape($key); + $courseid = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$unam,$courseid); + foreach my $key (keys(%roleshash)) { next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; if ($key eq $courseid.'_st') { $section=''; } - my ($dummy,$end,$start)=split(/\_/,&unescape($value)); + my ($dummy,$end,$start)=split(/\_/,&unescape($roleshash{$key})); my $now=time; if (defined($end) && $end && ($now > $end)) { $Expired{$end}=$section; @@ -947,10 +990,16 @@ my %remembered; my %accessed; my $kicks=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 { my ($name,$id,$debug) = @_; if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); $memcache->delete($id); delete($remembered{$id}); delete($accessed{$id}); @@ -958,7 +1007,7 @@ sub devalidate_cache_new { sub is_cached_new { my ($name,$id,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); if (exists($remembered{$id})) { if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } $accessed{$id}=[&gettimeofday()]; @@ -981,7 +1030,7 @@ sub is_cached_new { sub do_cache_new { my ($name,$id,$value,$time,$debug) = @_; - $id=&escape($name.':'.$id); + $id=&make_key($name,$id); my $setvalue=$value; if (!defined($setvalue)) { $setvalue='__undef__'; @@ -1684,6 +1733,12 @@ sub removeuserfile { if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { my $metafile = $fname.'.meta'; 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; @@ -1706,6 +1761,12 @@ sub renameuserfile { my $newmeta = $new.'.meta'; my $metaresult = &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; @@ -1772,7 +1833,7 @@ sub flushcourselogs { if ($entry =~ /___count$/) { my ($dom,$name); ($dom,$name,undef)= - ($entry=~m{___($match_domain)/($match_username)/(.*)___count$}); + ($entry=~m{___($match_domain)/($match_name)/(.*)___count$}); if (! defined($dom) || $dom eq '' || ! defined($name) || $name eq '') { my $cid = $env{'request.course.id'}; @@ -1793,7 +1854,7 @@ sub flushcourselogs { } } } 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}); if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { delete $accesshash{$entry}; @@ -2732,6 +2793,7 @@ sub coursedescription { if (!$args->{'one_time'}) { $envhash{'course.'.$normalid.'.last_cache'}=time; } + if ($chome ne 'no_host') { %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { @@ -2887,7 +2949,7 @@ sub group_roleprivs { if (($tend!=0) && ($tend<$now)) { $access = 0; } if (($tstart!=0) && ($tstart>$now)) { $access=0; } 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; } } @@ -2918,7 +2980,7 @@ sub set_userprivs { if (keys(%{$allgroups}) > 0) { foreach my $role (keys %{$allroles}) { 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; $area = $2; $sec = $3; @@ -3030,7 +3092,23 @@ sub dump { sub dumpstore { 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 @@ -3043,6 +3121,7 @@ sub getkeys { my $rep=reply("keys:$udomain:$uname:$namespace",$uhome); my @keyarray=(); foreach my $key (split(/\&/,$rep)) { + next if ($key =~ /^error: 2 /); push(@keyarray,&unescape($key)); } return @keyarray; @@ -3063,7 +3142,7 @@ sub currentdump { if ($rep eq "unknown_cmd") { # an old lond will not know 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)/); my %hash = @tmp; @tmp=(); @@ -3088,6 +3167,8 @@ sub convert_dump_to_currentdump{ # we might run in to problems with parameter names =~ /^v\./ while (my ($key,$value) = each(%hash)) { my ($v,$symb,$param) = split(/:/,$key); + $symb = &unescape($symb); + $param = &unescape($param); next if ($v eq 'version' || $symb eq 'keys'); next if (exists($returnhash{$symb}) && exists($returnhash{$symb}->{$param}) && @@ -3301,6 +3382,22 @@ sub portfolio_access { my ($requrl) = @_; my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); 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') { return 'F'; } elsif ($result =~ /^[^:]+:guest_/) { @@ -3376,7 +3473,7 @@ sub get_portfolio_access { my (%allgroups,%allroles); my ($start,$end,$role,$sec,$group); 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; if ($1 eq 'gr') { $group = $4; @@ -3389,7 +3486,7 @@ sub get_portfolio_access { } $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; if ($4 eq '') { $sec = 'none'; @@ -3484,12 +3581,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_username)/groups/([^/]+)/portfolio/(.+)$-) { + } elsif ($url =~ m-^/*(?:uploaded|editupload)/($match_domain)/($match_courseid)/groups/([^/]+)/portfolio/(.+)$-) { $type = 2; $udom = $1; $unum = $2; @@ -3509,7 +3606,7 @@ sub is_portfolio_url { sub is_portfolio_file { my ($file) = @_; - if (($file =~ /^portfolio/) || ($file =~ /^groups\/$match_username\/portfolio/)) { + if (($file =~ /^portfolio/) || ($file =~ /^groups\/\w+\/portfolio/)) { return 1; } return; @@ -3521,7 +3618,7 @@ sub is_portfolio_file { sub customaccess { my ($priv,$uri)=@_; 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); $ucrs = &LONCAPA::clean_username($ucrs); my $access=0; @@ -3554,12 +3651,21 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb)=@_; + my ($priv,$uri,$symb,$role)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$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}; } # Free bre access to adm and meta resources if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) @@ -3572,7 +3678,14 @@ sub allowed { my ($space,$domain,$name,@dir)=split('/',$uri); if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && ($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. @@ -3848,6 +3961,8 @@ sub allowed { unless ($env{'request.course.id'}) { if ($thisallowed eq 'A') { return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; } else { return '1'; } @@ -3915,6 +4030,8 @@ sub allowed { if ($thisallowed eq 'A') { return 'A'; + } elsif ($thisallowed eq 'B') { + return 'B'; } return 'F'; } @@ -4041,6 +4158,18 @@ sub log_query { 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) sub fetch_enrollment_query { @@ -4365,13 +4494,8 @@ sub auto_validate_class_sec { # ------------------------------------------------------- Course Group routines sub get_coursegroups { - my ($cdom,$cnum,$group) = @_; - return(&dump('coursegroups',$cdom,$cnum,$group)); -} - -sub get_deleted_groups { - my ($cdom,$cnum,$group) = @_; - return(&dump('deleted_groups',$cdom,$cnum,$group)); + my ($cdom,$cnum,$group,$namespace) = @_; + return(&dump($namespace,$cdom,$cnum,$group)); } sub modify_coursegroup { @@ -4379,18 +4503,26 @@ sub modify_coursegroup { return(&put('coursegroups',$groupsettings,$cdom,$cnum)); } -sub delete_coursegroup { - my ($cdom,$cnum,$group) = @_; - my %curr_group = &get_coursegroups($cdom,$cnum,$group); +sub toggle_coursegroup_status { + my ($cdom,$cnum,$group,$action) = @_; + my ($from_namespace,$to_namespace); + if ($action eq 'delete') { + $from_namespace = 'coursegroups'; + $to_namespace = 'deleted_groups'; + } else { + $from_namespace = 'deleted_groups'; + $to_namespace = 'coursegroups'; + } + my %curr_group = &get_coursegroups($cdom,$cnum,$group,$from_namespace); if (my $tmp = &error(%curr_group)) { &Apache::lonnet::logthis('Error retrieving group: '.$tmp.' in '.$cnum.':'.$cdom); return ('read error',$tmp); } else { my %savedsettings = %curr_group; - my $result = &put('deleted_groups',\%savedsettings,$cdom,$cnum); + my $result = &put($to_namespace,\%savedsettings,$cdom,$cnum); my $deloutcome; if ($result eq 'ok') { - $deloutcome = &del('coursegroups',[$group],$cdom,$cnum); + $deloutcome = &del($from_namespace,[$group],$cdom,$cnum); } else { return ('write error',$result); } @@ -4425,7 +4557,7 @@ sub get_active_groups { my $now = time; my %groups = (); 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}); if (($end!=0) && ($end<$now)) { next; } if (($start!=0) && ($start>$now)) { next; } @@ -4453,38 +4585,34 @@ sub get_users_groups { @usersgroups = split(/:/,$grouplist); } else { $grouplist = ''; - my %roleshash = &dump('roles',$udom,$uname,$courseid); - my ($tmp) = keys(%roleshash); - if ($tmp=~/^error:/) { - &logthis('Error retrieving roles: '.$tmp.' for '.$uname.':'.$udom); - } else { - my $access_end = $env{'course.'.$courseid. - '.default_enrollment_end_date'}; - my $now = time; - foreach my $key (keys(%roleshash)) { - if ($key =~ /^\Q$courseid\E\/(\w+)\_gr$/) { - my $group = $1; - if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { - my $start = $2; - my $end = $1; - if ($start == -1) { next; } # deleted from group - if (($start!=0) && ($start>$now)) { next; } - if (($end!=0) && ($end<$now)) { - if ($access_end && $access_end < $now) { - if ($access_end - $end < 86400) { - push(@usersgroups,$group); - } + my $courseurl = &courseid_to_courseurl($courseid); + my %roleshash = &dump('roles',$udom,$uname,$courseurl); + my $access_end = $env{'course.'.$courseid. + '.default_enrollment_end_date'}; + my $now = time; + foreach my $key (keys(%roleshash)) { + if ($key =~ /^\Q$courseurl\E\/(\w+)\_gr$/) { + my $group = $1; + if ($roleshash{$key} =~ /_(\d+)_(\d+)$/) { + my $start = $2; + my $end = $1; + if ($start == -1) { next; } # deleted from group + if (($start!=0) && ($start>$now)) { next; } + if (($end!=0) && ($end<$now)) { + 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; } @@ -4531,7 +4659,7 @@ sub assignrole { my $mrole; if ($role =~ /^cr\//) { my $cwosec=$url; - $cwosec=~s/^\/($match_domain)\/($match_username)\/.*/$1\/$2/; + $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless (&allowed('ccr',$cwosec)) { &logthis('Refused custom assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4541,8 +4669,7 @@ sub assignrole { $mrole='cr'; } elsif ($role =~ /^gr\//) { my $cwogrp=$url; - $cwogrp=~s{^/($match_domain)/($match_username)/.*} - {$1/$2}x; + $cwogrp=~s{^/($match_domain)/($match_courseid)/.*}{$1/$2}; unless (&allowed('mdg',$cwogrp)) { &logthis('Refused group assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4552,7 +4679,7 @@ sub assignrole { $mrole='gr'; } else { 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)) { &logthis('Refused assignrole: '. $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. @@ -4918,6 +5045,16 @@ ENDINITMAP 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 sub assigncustomrole { @@ -5196,6 +5333,15 @@ sub modify_access_controls { # remove lock my @del_lock = ($file_name."\0".'locked_access_records'); 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 { $outcome = "error: could not obtain lockfile\n"; } @@ -5431,7 +5577,7 @@ sub stat_file { my ($udom,$uname,$file,$dir); if ($uri =~ m-^/(uploaded|editupload)/-) { ($udom,$uname,$file) = - ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_username)/?(.*)-); + ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-); $file = 'userfiles/'.$file; $dir = &propath($udom,$uname); } @@ -6996,7 +7142,7 @@ sub repcopy_userfile { if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } 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 $uri="/uploaded/$cdom/$cnum/$filename"; if (-e "$file") { @@ -7027,14 +7173,7 @@ sub repcopy_userfile { } else { my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode); if ($lwpresp ne 'ok') { - my $ua=new LWP::UserAgent; - my $request=new HTTP::Request('GET',&tokenwrapper($uri)); - my $response=$ua->request($request); - if ($response->is_success()) { - $info=$response->content; - } else { - return -1; - } + return -1; } my @parts = ($cdom,$cnum); if ($filename =~ m|^(.+)/[^/]+$|) { @@ -7118,7 +7257,7 @@ sub filelocation { $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file 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 $is_me=0; my @ids=¤t_machine_ids(); @@ -7158,7 +7297,7 @@ sub hreflocation { } elsif ($file=~m-/home/($match_username)/public_html/-) { $file=~s-^/home/($match_username)/public_html/-/~$1/-; } 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; } return $file; @@ -7188,6 +7327,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 { @@ -7712,8 +7874,7 @@ passed in @what from the requested user' =item * -allowed($priv,$uri) : 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 U,I,K: authentication modes (cxx only) '': forbidden