--- loncom/lonnet/perl/lonnet.pm 2012/02/01 18:27:09 1.1056.4.33.2.1 +++ loncom/lonnet/perl/lonnet.pm 2010/06/03 17:04:41 1.1069 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1056.4.33.2.1 2012/02/01 18:27:09 raeburn Exp $ +# $Id: lonnet.pm,v 1.1069 2010/06/03 17:04:41 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -76,8 +76,7 @@ use HTTP::Date; use Image::Magick; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir - $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease - %managerstab); + $_64bit %env %protocol); my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, %userrolehash, $processmarker, $dumpcount, %coursedombuf, @@ -96,7 +95,6 @@ use Math::Random; use File::MMagic; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; -use File::Copy; my $readit; my $max_connection_retries = 10; # Or some such value. @@ -197,31 +195,8 @@ sub get_server_timezone { } } -sub get_server_distarch { - my ($lonhost,$ignore_cache) = @_; - if (defined($lonhost)) { - if (!defined(&hostname($lonhost))) { - return; - } - my $cachetime = 12*3600; - if (!$ignore_cache) { - my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost); - if (defined($cached)) { - return $distarch; - } - } - my $rep = &reply('serverdistarch',$lonhost); - unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || - $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' || - $rep eq '') { - return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime); - } - } - return; -} - sub get_server_loncaparev { - my ($dom,$lonhost,$ignore_cache,$caller) = @_; + my ($dom,$lonhost) = @_; if (defined($lonhost)) { if (!defined(&hostname($lonhost))) { undef($lonhost); @@ -236,74 +211,15 @@ sub get_server_loncaparev { } } if (defined($lonhost)) { - my $cachetime = 12*3600; - if (!$ignore_cache) { - my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); - if (defined($cached)) { - return $loncaparev; - } - } - my ($answer,$loncaparev); - my @ids=¤t_machine_ids(); - if (grep(/^\Q$lonhost\E$/,@ids)) { - $answer = $perlvar{'lonVersion'}; - if ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { - $loncaparev = $1; - } - } else { - $answer = &reply('serverloncaparev',$lonhost); - if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { - if ($caller eq 'loncron') { - my $ua=new LWP::UserAgent; - $ua->timeout(4); - my $protocol = $protocol{$lonhost}; - $protocol = 'http' if ($protocol ne 'https'); - my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; - my $request=new HTTP::Request('GET',$url); - my $response=$ua->request($request); - unless ($response->is_error()) { - my $content = $response->content; - if ($content =~ /

VERSION\:\s*([\w.\-]+)<\/p>/) { - $loncaparev = $1; - } - } - } else { - $loncaparev = $loncaparevs{$lonhost}; - } - } elsif ($answer =~ /^[\'\"]?([\w.\-]+)[\'\"]?$/) { - $loncaparev = $1; - } - } - return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); - } -} - -sub get_server_homeID { - my ($hostname,$ignore_cache,$caller) = @_; - unless ($ignore_cache) { - my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname); + my $cachetime = 24*3600; + my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); if (defined($cached)) { - return $serverhomeID; - } - } - my $cachetime = 12*3600; - my $serverhomeID; - if ($caller eq 'loncron') { - my @machine_ids = &machine_ids($hostname); - foreach my $id (@machine_ids) { - my $response = &reply('serverhomeID',$id); - unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) { - $serverhomeID = $response; - last; - } - } - if ($serverhomeID eq '') { - $serverhomeID = $machine_ids[-1]; + return $loncaparev; + } else { + my $loncaparev = &reply('serverloncaparev',$lonhost); + return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); } - } else { - $serverhomeID = $serverhomeIDs{$hostname}; } - return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime); } # -------------------------------------------------- Non-critical communication @@ -749,50 +665,16 @@ sub userload { return $userloadpercent; } -# ------------------------------------------ Fight off request when overloaded - -sub overloaderror { - my ($r,$checkserver)=@_; - unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } - my $loadavg; - if ($checkserver eq $perlvar{'lonHostID'}) { - open(my $loadfile,'/proc/loadavg'); - $loadavg=<$loadfile>; - $loadavg =~ s/\s.*//g; - $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; - close($loadfile); - } else { - $loadavg=&reply('load',$checkserver); - } - my $overload=$loadavg-100; - if ($overload>0) { - $r->err_headers_out->{'Retry-After'}=$overload; - $r->log_error('Overload of '.$overload.' on '.$checkserver); - return 413; - } - return ''; -} - # ------------------------------ Find server with least workload from spare.tab sub spareserver { - my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_; + my ($loadpercent,$userloadpercent,$want_server_name) = @_; my $spare_server; if ($userloadpercent !~ /\d/) { $userloadpercent=0; } my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent : $userloadpercent; - my ($uint_dom,$remotesessions); - if (($udom ne '') && (&domain($udom) ne '')) { - my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); - $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); - my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); - $remotesessions = $udomdefaults{'remotesessions'}; - } + foreach my $try_server (@{ $spareid{'primary'} }) { - if ($uint_dom) { - next unless (&spare_can_host($udom,$uint_dom,$remotesessions, - $try_server)); - } ($spare_server, $lowest_load) = &compare_server_load($try_server, $spare_server, $lowest_load); } @@ -801,10 +683,6 @@ sub spareserver { if (!$found_server) { foreach my $try_server (@{ $spareid{'default'} }) { - if ($uint_dom) { - next unless (&spare_can_host($udom,$uint_dom,$remotesessions, - $try_server)); - } ($spare_server, $lowest_load) = &compare_server_load($try_server, $spare_server, $lowest_load); } @@ -817,7 +695,7 @@ sub spareserver { } if (defined($spare_server)) { my $hostname = &hostname($spare_server); - if (defined($hostname)) { + if (defined($hostname)) { $spare_server = $protocol.'://'.$hostname; } } @@ -832,7 +710,7 @@ sub compare_server_load { my $userloadans = &reply('userload',$try_server); if ($loadans !~ /\d/ && $userloadans !~ /\d/) { - return ($spare_server, $lowest_load); #didn't get a number from the server + next; #didn't get a number from the server } my $load; @@ -875,45 +753,6 @@ sub has_user_session { return 0; } -# --------- determine least loaded server in a user's domain which allows login - -sub choose_server { - my ($udom,$checkloginvia) = @_; - my %domconfhash = &Apache::loncommon::get_domainconf($udom); - my %servers = &get_servers($udom); - my $lowest_load = 30000; - my ($login_host,$hostname,$portal_path,$isredirect); - foreach my $lonhost (keys(%servers)) { - my $loginvia; - if ($checkloginvia) { - $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; - if ($loginvia) { - my ($server,$path) = split(/:/,$loginvia); - ($login_host, $lowest_load) = - &compare_server_load($lonhost, $login_host, $lowest_load); - if ($login_host eq $server) { - $portal_path = $path; - $isredirect = 1; - } - } else { - ($login_host, $lowest_load) = - &compare_server_load($lonhost, $login_host, $lowest_load); - if ($login_host eq $lonhost) { - $portal_path = ''; - $isredirect = ''; - } - } - } else { - ($login_host, $lowest_load) = - &compare_server_load($lonhost, $login_host, $lowest_load); - } - } - if ($login_host ne '') { - $hostname = &hostname($login_host); - } - return ($login_host,$hostname,$portal_path,$isredirect); -} - # --------------------------------------------- Try to change a user's password sub changepass { @@ -972,7 +811,7 @@ sub queryauthenticate { # --------- Try to authenticate user from domain's lib servers (first this one) sub authenticate { - my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_; + my ($uname,$upass,$udom,$checkdefauth)=@_; $upass=&escape($upass); $uname= &LONCAPA::clean_username($uname); my $uhome=&homeserver($uname,$udom,1); @@ -995,7 +834,7 @@ sub authenticate { return 'no_host'; } } - my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome); + my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome); if ($answer eq 'authorized') { if ($newhome) { &logthis("User $uname at $udom authorized by $uhome, but needs account"); @@ -1013,88 +852,6 @@ sub authenticate { return 'no_host'; } -sub can_host_session { - my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_; - my $canhost = 1; - my $host_idn = &Apache::lonnet::internet_dom($lonhost); - if (ref($remotesessions) eq 'HASH') { - if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') { - if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) { - $canhost = 0; - } else { - $canhost = 1; - } - } - if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') { - if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) { - $canhost = 1; - } else { - $canhost = 0; - } - } - if ($canhost) { - if ($remotesessions->{'version'} ne '') { - my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/); - if ($reqmajor ne '' && $reqminor ne '') { - if ($remoterev =~ /^\'?(\d+)\.(\d+)/) { - my $major = $1; - my $minor = $2; - if (($major < $reqmajor ) || - (($major == $reqmajor) && ($minor < $reqminor))) { - $canhost = 0; - } - } else { - $canhost = 0; - } - } - } - } - } - if ($canhost) { - if (ref($hostedsessions) eq 'HASH') { - my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); - my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); - if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { - if (($uint_dom ne '') && - (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) { - $canhost = 0; - } else { - $canhost = 1; - } - } - if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { - if (($uint_dom ne '') && - (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) { - $canhost = 1; - } else { - $canhost = 0; - } - } - } - } - return $canhost; -} - -sub spare_can_host { - my ($udom,$uint_dom,$remotesessions,$try_server)=@_; - my $canhost=1; - my @intdoms; - my $internet_names = &Apache::lonnet::get_internet_names($try_server); - if (ref($internet_names) eq 'ARRAY') { - @intdoms = @{$internet_names}; - } - unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { - my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server); - my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); - my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom); - my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server); - $canhost = &can_host_session($udom,$try_server,$remoterev, - $remotesessions, - $defdomdefaults{'hostedsessions'}); - } - return $canhost; -} - # ---------------------- Find the homebase for a user from domain's lib servers my %homecache; @@ -1571,14 +1328,13 @@ sub get_domain_defaults { my %domconfig = &Apache::lonnet::get_dom('configuration',['defaults','quotas', 'requestcourses','inststatus', - 'coursedefaults','usersessions'],$domain); + 'coursedefaults'],$domain); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; - $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -1612,14 +1368,6 @@ sub get_domain_defaults { $domdefaults{$item} = $domconfig{'coursedefaults'}{$item}; } } - if (ref($domconfig{'usersessions'}) eq 'HASH') { - if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { - $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'}; - } - if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') { - $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; - } - } &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, $cachetime); return %domdefaults; @@ -1805,8 +1553,7 @@ sub getsection { # If there is a role which has expired, return it. # $courseid = &courseid_to_courseurl($courseid); - my $extra = &freeze_escape({'skipcheck' => 1}); - my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra); + my %roleshash = &dump('roles',$udom,$unam,$courseid); foreach my $key (keys(%roleshash)) { next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/); my $section=$1; @@ -2247,8 +1994,6 @@ sub allowuploaded { # path to file, source of file, instruction to parse file for objects, # ref to hash for embedded objects, # ref to hash for codebase of java objects. -# reference to scalar to accommodate mime type determined -# from File::MMagic if $parser = parse. # # output: url to file (if action was uploaddoc), # ok if successful, or diagnostic message otherwise (if action was propagate or copy) @@ -2275,8 +2020,7 @@ sub allowuploaded { # sub process_coursefile { - my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase, - $mimetype)=@_; + my ($action,$docuname,$docudom,$file,$source,$parser,$allfiles,$codebase)=@_; my $fetchresult; my $home=&homeserver($docuname,$docudom); if ($action eq 'propagate') { @@ -2304,16 +2048,13 @@ sub process_coursefile { close($fh); if ($parser eq 'parse') { my $mm = new File::MMagic; - my $type = $mm->checktype_filename($filepath.'/'.$fname); - if ($type eq 'text/html') { + my $mime_type = $mm->checktype_filename($filepath.'/'.$fname); + if ($mime_type eq 'text/html') { my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); unless ($parse_result eq 'ok') { &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); } } - if (ref($mimetype)) { - $$mimetype = $type; - } } $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, $home); @@ -2429,13 +2170,9 @@ sub resizeImage { # --------------- Take an uploaded file and put it into the userfiles directory # input: $formname - the contents of the file are in $env{"form.$formname"} -# the desired filename is in $env{"form.$formname.filename"} -# $context - possible values: coursedoc, existingfile, overwrite, -# canceloverwrite, or ''. -# if 'coursedoc': upload to the current course -# if 'existingfile': write file to tmp/overwrites directory -# if 'canceloverwrite': delete file written to tmp/overwrites directory -# $context is passed as argument to &finishuserfileupload +# the desired filenam is in $env{"form.$formname.filename"} +# $coursedoc - if true up to the current course +# if false # $subdir - directory in userfile to store the file into # $parser - instruction to parse file for objects ($parser = parse) # $allfiles - reference to hash for embedded objects @@ -2446,60 +2183,37 @@ sub resizeImage { # $thumbheight - height (pixels) of thumbnail to make for uploaded image # $resizewidth - width (pixels) to which to resize uploaded image # $resizeheight - height (pixels) to which to resize uploaded image -# $mimetype - reference to scalar to accommodate mime type determined -# from File::MMagic if $parser = parse. # # output: url of file in userspace, or error: # or /adm/notfound.html if failure to upload occurse sub userfileupload { - my ($formname,$context,$subdir,$parser,$allfiles,$codebase,$destuname, - $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight,$mimetype)=@_; + my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, + $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_; if (!defined($subdir)) { $subdir='unknown'; } my $fname=$env{'form.'.$formname.'.filename'}; $fname=&clean_filename($fname); - # See if there is anything left +# See if there is anything left unless ($fname) { return 'error: no uploaded file'; } - # Files uploaded to help request form, or uploaded to "create course" page are handled differently - if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) || - (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) || - ($context eq 'existingfile') || ($context eq 'canceloverwrite')) { + chop($env{'form.'.$formname}); + if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { #files uploaded to help request form are handled differently my $now = time; - my $filepath; - if (($formname eq 'screenshot') && ($subdir eq 'helprequests')) { - $filepath = 'tmp/helprequests/'.$now; - } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { - $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}. - '_'.$env{'user.domain'}.'/pending'; - } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { - my ($docuname,$docudom); - if ($destudom) { - $docudom = $destudom; - } else { - $docudom = $env{'user.domain'}; - } - if ($destuname) { - $docuname = $destuname; - } else { - $docuname = $env{'user.name'}; - } - if (exists($env{'form.group'})) { - $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; - $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; - } - $filepath = 'tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$subdir; - if ($context eq 'canceloverwrite') { - my $tempfile = $perlvar{'lonDaemons'}.'/'.$filepath.'/'.$fname; - if (-e $tempfile) { - my @info = stat($tempfile); - if ($info[9] eq $env{'form.timestamp'}) { - unlink($tempfile); - } - } - return; + my $filepath = 'tmp/helprequests/'.$now; + my @parts=split(/\//,$filepath); + my $fullpath = $perlvar{'lonDaemons'}; + for (my $i=0;$i<@parts;$i++) { + $fullpath .= '/'.$parts[$i]; + if ((-e $fullpath)!=1) { + mkdir($fullpath,0777); } } - # Create the directory if not present + open(my $fh,'>'.$fullpath.'/'.$fname); + print $fh $env{'form.'.$formname}; + close($fh); + return $fullpath.'/'.$fname; + } elsif (($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) { #files uploaded to create course page are handled differently + my $filepath = 'tmp/addcourse/'.$destudom.'/web/'.$env{'user.name'}. + '_'.$env{'user.domain'}.'/pending'; my @parts=split(/\//,$filepath); my $fullpath = $perlvar{'lonDaemons'}; for (my $i=0;$i<@parts;$i++) { @@ -2511,31 +2225,27 @@ sub userfileupload { open(my $fh,'>'.$fullpath.'/'.$fname); print $fh $env{'form.'.$formname}; close($fh); - if ($context eq 'existingfile') { - my @info = stat($fullpath.'/'.$fname); - return ($fullpath.'/'.$fname,$info[9]); - } else { - return $fullpath.'/'.$fname; - } + return $fullpath.'/'.$fname; } if ($subdir eq 'scantron') { $fname = 'scantron_orig_'.$fname; - } else { + } else { +# Create the directory if not present $fname="$subdir/$fname"; } - if ($context eq 'coursedoc') { + if ($coursedoc) { my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; if ($env{'form.folder'} =~ m/^(default|supplemental)/) { return &finishuserfileupload($docuname,$docudom, $formname,$fname,$parser,$allfiles, $codebase,$thumbwidth,$thumbheight, - $resizewidth,$resizeheight,$context,$mimetype); + $resizewidth,$resizeheight); } else { $fname=$env{'form.folder'}.'/'.$fname; return &process_coursefile('uploaddoc',$docuname,$docudom, $fname,$formname,$parser, - $allfiles,$codebase,$mimetype); + $allfiles,$codebase); } } elsif (defined($destuname)) { my $docuname=$destuname; @@ -2543,7 +2253,8 @@ sub userfileupload { return &finishuserfileupload($docuname,$docudom,$formname,$fname, $parser,$allfiles,$codebase, $thumbwidth,$thumbheight, - $resizewidth,$resizeheight,$context,$mimetype); + $resizewidth,$resizeheight); + } else { my $docuname=$env{'user.name'}; my $docudom=$env{'user.domain'}; @@ -2554,13 +2265,13 @@ sub userfileupload { return &finishuserfileupload($docuname,$docudom,$formname,$fname, $parser,$allfiles,$codebase, $thumbwidth,$thumbheight, - $resizewidth,$resizeheight,$context,$mimetype); + $resizewidth,$resizeheight); } } sub finishuserfileupload { my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, - $thumbwidth,$thumbheight,$resizewidth,$resizeheight,$context,$mimetype) = @_; + $thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; @@ -2586,23 +2297,7 @@ sub finishuserfileupload { print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); return '/adm/notfound.html'; } - if ($context eq 'overwrite') { - my $source = $perlvar{'lonDaemons'}.'/tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$fname; - my $target = $filepath.'/'.$file; - if (-e $source) { - my @info = stat($source); - if ($info[9] eq $env{'form.timestamp'}) { - unless (&File::Copy::move($source,$target)) { - &logthis('Failed to overwrite '.$filepath.'/'.$file); - return "Moving from $source failed"; - } - } else { - return "Temporary file: $source had unexpected date/time for last modification"; - } - } else { - return "Temporary file: $source missing"; - } - } elsif (!print FH ($env{'form.'.$formname})) { + if (!print FH ($env{'form.'.$formname})) { &logthis('Failed to write to '.$filepath.'/'.$file); print STDERR ('Failed to write to '.$filepath.'/'.$file."\n"); return '/adm/notfound.html'; @@ -2618,8 +2313,8 @@ sub finishuserfileupload { } if ($parser eq 'parse') { my $mm = new File::MMagic; - my $type = $mm->checktype_filename($filepath.'/'.$file); - if ($type eq 'text/html') { + my $mime_type = $mm->checktype_filename($filepath.'/'.$file); + if ($mime_type eq 'text/html') { my $parse_result = &extract_embedded_items($filepath.'/'.$file, $allfiles,$codebase); unless ($parse_result eq 'ok') { @@ -2627,9 +2322,6 @@ sub finishuserfileupload { ' for embedded media: '.$parse_result); } } - if (ref($mimetype)) { - $$mimetype = $type; - } } if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { my $input = $filepath.'/'.$file; @@ -3164,8 +2856,7 @@ sub get_my_roles { unless (defined($udom)) { $udom=$env{'user.domain'}; } my (%dumphash,%nothide); if ($context eq 'userroles') { - my $extra = &freeze_escape({'skipcheck' => 1}); - %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra); + %dumphash = &dump('roles',$udom,$uname); } else { %dumphash= &dump('nohist_userroles',$udom,$uname); @@ -3344,7 +3035,7 @@ sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, - $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_; + $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -3366,8 +3057,7 @@ sub courseiddump { $showhidden.':'.$caller.':'.&escape($cloner).':'. &escape($cc_clone).':'.$cloneonly.':'. &escape($createdbefore).':'.&escape($createdafter).':'. - &escape($creationcontext).':'.$domcloner, - $tryserver); + &escape($creationcontext),$tryserver); my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -3493,7 +3183,7 @@ sub get_domain_roles { return %personnel; } -# ----------------------------------------------------------- Check out an item +# ----------------------------------------------------------- Interval timing sub get_first_access { my ($type,$argsymb)=@_; @@ -3529,91 +3219,6 @@ sub set_first_access { return 'already_set'; } -sub checkout { - my ($symb,$tuname,$tudom,$tcrsid)=@_; - my $now=time; - my $lonhost=$perlvar{'lonHostID'}; - my $infostr=&escape( - 'CHECKOUTTOKEN&'. - $tuname.'&'. - $tudom.'&'. - $tcrsid.'&'. - $symb.'&'. - $now.'&'.$ENV{'REMOTE_ADDR'}); - my $token=&reply('tmpput:'.$infostr,$lonhost); - if ($token=~/^error\:/) { - &logthis("WARNING: ". - "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb. - ""); - return ''; - } - - $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/; - $token=~tr/a-z/A-Z/; - - my %infohash=('resource.0.outtoken' => $token, - 'resource.0.checkouttime' => $now, - 'resource.0.outremote' => $ENV{'REMOTE_ADDR'}); - - unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { - return ''; - } else { - &logthis("WARNING: ". - "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb. - ""); - } - - if (&log($tudom,$tuname,&homeserver($tuname,$tudom), - &escape('Checkout '.$infostr.' - '. - $token)) ne 'ok') { - return ''; - } else { - &logthis("WARNING: ". - "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb. - ""); - } - return $token; -} - -# ------------------------------------------------------------ Check in an item - -sub checkin { - my $token=shift; - my $now=time; - my ($ta,$tb,$lonhost)=split(/\*/,$token); - $lonhost=~tr/A-Z/a-z/; - my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb; - $dtoken=~s/\W/\_/g; - my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)= - split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost))); - - unless (($tuname) && ($tudom)) { - &logthis('Check in '.$token.' ('.$dtoken.') failed'); - return ''; - } - - unless (&allowed('mgr',$tcrsid)) { - &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '. - $env{'user.name'}.' - '.$env{'user.domain'}); - return ''; - } - - my %infohash=('resource.0.intoken' => $token, - 'resource.0.checkintime' => $now, - 'resource.0.inremote' => $ENV{'REMOTE_ADDR'}); - - unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') { - return ''; - } - - if (&log($tudom,$tuname,&homeserver($tuname,$tudom), - &escape('Checkin - '.$token)) ne 'ok') { - return ''; - } - - return ($symb,$tuname,$tudom,$tcrsid); -} - # --------------------------------------------- Set Expire Date for Spreadsheet sub expirespread { @@ -3718,7 +3323,7 @@ sub hashref2str { $result.='='; #print("Got a ref of ".(ref($key))." skipping."); } else { - if (defined($key)) {$result.=&escape($key).'=';} else { last; } + if ($key) {$result.=&escape($key).'=';} else { last; } } if(ref($hashref->{$key}) eq 'ARRAY') { @@ -4152,44 +3757,6 @@ sub coursedescription { return %returnhash; } -sub update_released_required { - my ($needsrelease,$cdom,$cnum,$chome,$cid) = @_; - if ($cdom eq '' || $cnum eq '' || $chome eq '' || $cid eq '') { - $cid = $env{'request.course.id'}; - $cdom = $env{'course.'.$cid.'.domain'}; - $cnum = $env{'course.'.$cid.'.num'}; - $chome = $env{'course.'.$cid.'.home'}; - } - if ($needsrelease) { - my %curr_reqd_hash = &userenvironment($cdom,$cnum,'internal.releaserequired'); - my $needsupdate; - if ($curr_reqd_hash{'internal.releaserequired'} eq '') { - $needsupdate = 1; - } else { - my ($currmajor,$currminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); - my ($needsmajor,$needsminor) = split(/\./,$needsrelease); - if (($currmajor < $needsmajor) || ($currmajor == $needsmajor && $currminor < $needsminor)) { - $needsupdate = 1; - } - } - if ($needsupdate) { - my %needshash = ( - 'internal.releaserequired' => $needsrelease, - ); - my $putresult = &put('environment',\%needshash,$cdom,$cnum); - if ($putresult eq 'ok') { - &appenv({'course.'.$cid.'.internal.releaserequired' => $needsrelease}); - my %crsinfo = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); - if (ref($crsinfo{$cid}) eq 'HASH') { - $crsinfo{$cid}{'releaserequired'} = $needsrelease; - &courseidput($cdom,\%crsinfo,$chome,'notime'); - } - } - } - } - return; -} - # -------------------------------------------------See if a user is privileged sub privileged { @@ -4229,10 +3796,9 @@ sub rolesinit { my ($domain,$username,$authhost)=@_; my $now=time; my %userroles = ('user.login.time' => $now); - my $extra = &freeze_escape({'skipcheck' => 1}); - my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost); + my $rolesdump=reply("dump:$domain:$username:roles",$authhost); if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || - ($rolesdump =~ /^error:/)) { + ($rolesdump =~ /^error:/)) { return \%userroles; } my %allroles=(); @@ -4358,7 +3924,7 @@ sub set_userprivs { my $adv=0; my %grouproles = (); if (keys(%{$allgroups}) > 0) { - my @groupkeys; + my @groupkeys; foreach my $role (keys(%{$allroles})) { push(@groupkeys,$role); } @@ -4434,7 +4000,7 @@ sub role_status { my %userroles = ( 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend ); - @rolecodes = ('cm'); + @rolecodes = ('cm'); my $spec=$$role.'.'.$$where; my ($tdummy,$tdomain,$trest)=split(/\//,$$where); if ($$role =~ /^cr\//) { @@ -4451,7 +4017,7 @@ sub role_status { my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1); if (keys(%course_roles) > 0) { my ($tnum) = ($trest =~ /^($match_courseid)/); - if ($tdomain ne '' && $tnum ne '') { + if ($tdomain ne '' && $tnum ne '') { foreach my $key (keys(%course_roles)) { if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) { my $crsrole = $1; @@ -4499,22 +4065,22 @@ sub role_status { } sub check_adhoc_privs { - my ($cdom,$cnum,$then,$refresh,$now,$checkrole,$caller) = @_; + my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_; my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; if ($env{$cckey}) { my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { - &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); + &set_adhoc_privileges($cdom,$cnum,$checkrole); } } else { - &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); + &set_adhoc_privileges($cdom,$cnum,$checkrole); } } sub set_adhoc_privileges { # role can be cc or ca - my ($dcdom,$pickedcourse,$role,$caller) = @_; + my ($dcdom,$pickedcourse,$role) = @_; my $area = '/'.$dcdom.'/'.$pickedcourse; my $spec = $role.'.'.$area; my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, @@ -4524,16 +4090,14 @@ sub set_adhoc_privileges { my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); &appenv(\%userroles,[$role,'cm']); &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); - unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { - &appenv( {'request.role' => $spec, - 'request.role.domain' => $dcdom, - 'request.course.sec' => '' - } - ); - my $tadv=0; - if (&allowed('adv') eq 'F') { $tadv=1; } - &appenv({'request.role.adv' => $tadv}); - } + &appenv( {'request.role' => $spec, + 'request.role.domain' => $dcdom, + 'request.course.sec' => '' + } + ); + my $tadv=0; + if (&allowed('adv') eq 'F') { $tadv=1; } + &appenv({'request.role.adv' => $tadv}); } # --------------------------------------------------------------- get interface @@ -4582,7 +4146,7 @@ sub del { # -------------------------------------------------------------- dump interface sub dump { - my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_; + my ($namespace,$udomain,$uname,$regexp,$range)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); @@ -4591,7 +4155,7 @@ sub dump { } else { $regexp='.'; } - my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome); + my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); foreach my $item (@pairs) { @@ -5136,7 +4700,7 @@ sub is_portfolio_file { } sub usertools_access { - my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_; + my ($uname,$udom,$tool,$action,$context) = @_; my ($access,%tools); if ($context eq '') { $context = 'tools'; @@ -5178,14 +4742,9 @@ sub usertools_access { $toolstatus = $env{'environment.'.$context.'.'.$tool}; $inststatus = $env{'environment.inststatus'}; } else { - if (ref($userenvref) eq 'HASH') { - $toolstatus = $userenvref->{$context.'.'.$tool}; - $inststatus = $userenvref->{'inststatus'}; - } else { - my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); - $toolstatus = $userenv{$context.'.'.$tool}; - $inststatus = $userenv{'inststatus'}; - } + my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); + $toolstatus = $userenv{$context.'.'.$tool}; + $inststatus = $userenv{'inststatus'}; } if ($toolstatus ne '') { @@ -5197,17 +4756,8 @@ sub usertools_access { return $access; } - my ($is_adv,%domdef); - if (ref($is_advref) eq 'HASH') { - $is_adv = $is_advref->{'is_adv'}; - } else { - $is_adv = &is_advanced_user($udom,$uname); - } - if (ref($domdefref) eq 'HASH') { - %domdef = %{$domdefref}; - } else { - %domdef = &get_domain_defaults($udom); - } + my $is_adv = &is_advanced_user($udom,$uname); + my %domdef = &get_domain_defaults($udom); if (ref($domdef{$tool}) eq 'HASH') { if ($is_adv) { if ($domdef{$tool}{'_LC_adv'} ne '') { @@ -5281,11 +4831,6 @@ sub is_course_owner { sub is_advanced_user { my ($udom,$uname) = @_; - if ($udom ne '' && $uname ne '') { - if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { - return $env{'user.adv'}; - } - } my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); my %allroles; my $is_adv; @@ -5801,7 +5346,7 @@ sub allowed { my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/\Q$rolecode\E/) { - if (($priv ne 'pch') && ($priv ne 'plc')) { + if ($priv ne 'pch') { &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $env{'request.course.id'}); @@ -5811,7 +5356,7 @@ sub allowed { if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} =~/\Q$unamedom\E/) { - if (($priv ne 'pch') && ($priv ne 'plc')) { + if ($priv ne 'pch') { &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. $env{'request.course.id'}); @@ -5825,7 +5370,7 @@ sub allowed { if ($thisallowed=~/R/) { my $rolecode=(split(/\./,$env{'request.role'}))[0]; if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { - if (($priv ne 'pch') && ($priv ne 'plc')) { + if ($priv ne 'pch') { &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); } @@ -6008,7 +5553,8 @@ sub update_allusers_table { 'generation='.&escape($names->{'generation'}).'%%'. 'permanentemail='.&escape($names->{'permanentemail'}).'%%'. 'id='.&escape($names->{'id'}),$homeserver); - return; + my $reply = &get_query_reply($queryid); + return $reply; } # ------- Request retrieval of institutional classlists for course(s) @@ -6178,9 +5724,9 @@ sub auto_get_sections { } sub auto_new_course { - my ($cnum,$cdom,$inst_course_id,$owner,$coowners) = @_; + my ($cnum,$cdom,$inst_course_id,$owner) = @_; my $homeserver = &homeserver($cnum,$cdom); - my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.&escape($owner).':'.$cdom.':'.&escape($coowners),$homeserver)); + my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver)); return $response; } @@ -6571,8 +6117,7 @@ sub get_users_groups { } else { $grouplist = ''; my $courseurl = &courseid_to_courseurl($courseid); - my $extra = &freeze_escape({'skipcheck' => 1}); - my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra); + my %roleshash = &dump('roles',$udom,$uname,$courseurl); my $access_end = $env{'course.'.$courseid. '.default_enrollment_end_date'}; my $now = time; @@ -6752,13 +6297,6 @@ sub assignrole { return 'refused'; } } - } elsif ($role eq 'au') { - if ($url ne '/'.$udom.'/') { - &logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}. - ' to assign author role for '.$uname.':'.$udom. - ' in domain: '.$url.' refused (wrong domain).'); - return 'refused'; - } } $mrole=$role; } @@ -6933,16 +6471,12 @@ sub modifyuser { } &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. - $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. + $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). ' by '.$env{'user.name'}.' at '.$env{'user.domain'}. ' in domain '.$env{'request.role.domain'}); my $uhome=&homeserver($uname,$udom,'true'); - my $newuser; - if ($uhome eq 'no_host') { - $newuser = 1; - } # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && (($umode && $upass) || ($umode eq 'localauth'))) { @@ -6995,12 +6529,11 @@ sub modifyuser { ['firstname','middlename','lastname','generation','id', 'permanentemail','inststatus'], $udom,$uname); - my (%names,%oldnames); + my %names; if ($tmp[0] =~ m/^error:.*/) { %names=(); } else { %names = @tmp; - %oldnames = %names; } # # If name, email and/or uid are blank (e.g., because an uploaded file @@ -7054,40 +6587,18 @@ sub modifyuser { } } } - my $logmsg = $udom.', '.$uname.', '.$uid.', '. + my $reply = &put('environment', \%names, $udom,$uname); + if ($reply ne 'ok') { return 'error: '.$reply; } + my $sqlresult = &update_allusers_table($uname,$udom,\%names); + &devalidate_cache_new('namescache',$uname.':'.$udom); + my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. - $last.', '.$gene.', '.$email.', '.$inststatus; + $last.', '.$gene.', '.$email.', '.$inststatus; if ($env{'user.name'} ne '' && $env{'user.domain'}) { $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'}; } else { $logmsg .= ' during self creation'; } - my $changed; - if ($newuser) { - $changed = 1; - } else { - foreach my $field (@fields) { - if ($names{$field} ne $oldnames{$field}) { - $changed = 1; - last; - } - } - } - unless ($changed) { - $logmsg = 'No changes in user information needed for: '.$logmsg; - &logthis($logmsg); - return 'ok'; - } - my $reply = &put('environment', \%names, $udom,$uname); - if ($reply ne 'ok') { - return 'error: '.$reply; - } - if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { - &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom); - } - my $sqlresult = &update_allusers_table($uname,$udom,\%names); - &devalidate_cache_new('namescache',$uname.':'.$udom); - $logmsg = 'Success modifying user '.$logmsg; &logthis($logmsg); return 'ok'; } @@ -7404,8 +6915,8 @@ sub store_userdata { $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; } $namevalue=~s/\&$//; - $result = &reply("store:$udom:$uname:$namespace:$datakey:". - $namevalue,$uhome); + $result = &reply("store:$env{'user.domain'}:$env{'user.name'}:". + "$namespace:$datakey:$namevalue",$uhome); } } else { $result = 'error: data to store was not a hash reference'; @@ -7458,10 +6969,10 @@ sub diskusage { } sub is_locked { - my ($file_name, $domain, $user, $which) = @_; + my ($file_name, $domain, $user) = @_; my @check; my $is_locked; - push(@check,$file_name); + push @check, $file_name; my %locked = &get('file_permissions',\@check, $env{'user.domain'},$env{'user.name'}); my ($tmp)=keys(%locked); @@ -7470,19 +6981,14 @@ sub is_locked { if (ref($locked{$file_name}) eq 'ARRAY') { $is_locked = 'false'; foreach my $entry (@{$locked{$file_name}}) { - if (ref($entry) eq 'ARRAY') { + if (ref($entry) eq 'ARRAY') { $is_locked = 'true'; - if (ref($which) eq 'ARRAY') { - push(@{$which},$entry); - } else { - last; - } + last; } } } else { $is_locked = 'false'; } - return $is_locked; } sub declutter_portfile { @@ -8632,7 +8138,7 @@ sub metadata { if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || - ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) { return undef; } if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) @@ -8651,6 +8157,9 @@ sub metadata { if (defined($cached)) { return $result->{':'.$what}; } } { +# Imported parts would go here + my @newpartorder=(); + my $importedparts=0; # # Is this a recursive call for a library? # @@ -8674,8 +8183,7 @@ sub metadata { &Apache::lonnet::ssi_body($which, ('grade_target' => 'meta')); $cachetime = 1; # only want this cached in the child not long term - } elsif (($uri !~ m -^(editupload)/-) && - ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) { + } elsif ($uri !~ m -^(editupload)/-) { my $file=&filelocation('',&clutter($filename)); #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); @@ -8735,27 +8243,57 @@ sub metadata { # This is not a package - some other kind of start tag # my $entry=$token->[1]; - my $unikey; - if ($entry eq 'import') { - $unikey=''; - } else { - $unikey=$entry; - } - $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); - - if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; - } + my $unikey=''; if ($entry eq 'import') { # # Importing a library here # + my $location=$parser->get_text('/import'); + my $dir=$filename; + $dir=~s|[^/]*$||; + $location=&filelocation($dir,$location); + + my $importmode=$token->[2]->{'importmode'}; + if ($importmode eq 'problem') { +# Import as problem/response + $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + } elsif ($importmode eq 'part') { +# Import as part(s) + $importedparts=1; +# We need to get the original file and the imported file to get the part order correct +# Good news: we do not need to worry about nested libraries, since parts cannot be nested +# Load and inspect original file + my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); + my $origfile=&getfile($origfilelocation); + my @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); +# Load and inspect imported file + my $impfile=&getfile($location); + my @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + +#&logthis("Found imported parts".join(',',@impfilepartids)); +#&logthis("Found original parts and imports".join(',',@origfileimportpartids)); + if ($#impfilepartids>=0) { +# This problem had parts +#&logthis("Importing parted problem"); + } else { +# Importing by turning a single problem into a problem part +# It gets the import-tags ID as part-ID +#&logthis("Importing unparted problem"); + $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'}); + push(@newpartorder,$token->[2]->{'id'}); + } + } else { +# Normal import + $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } + } + +#&logthis("About to use unikey $unikey"); + if ($depthcount<20) { - my $location=$parser->get_text('/import'); - my $dir=$filename; - $dir=~s|[^/]*$||; - $location=&filelocation($dir,$location); my $metadata = &metadata($uri,'keys', $location,$unikey, $depthcount+1); @@ -8763,8 +8301,17 @@ sub metadata { $metaentry{':'.$meta}=$metaentry{':'.$meta}; $metathesekeys{$meta}=1; } - } - } else { + +#&logthis("Metadata $metadata"); + } + } else { +# +# Not importing, some other kind of non-package, non-library start tag +# + $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'}); + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } if (defined($token->[2]->{'name'})) { $unikey.='_'.$token->[2]->{'name'}; } @@ -9023,8 +8570,7 @@ sub symbverify { } my $ids=$bighash{'ids_'.&clutter($thisurl)}; unless ($ids) { - my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; - $ids=$bighash{$idkey}; + $ids=$bighash{'ids_/'.$thisurl}; } if ($ids) { # ------------------------------------------------------------------- Has ID(s) @@ -9037,8 +8583,7 @@ sub symbverify { &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { if (($env{'request.role.adv'}) || - ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || - ($thisurl eq '/adm/navmaps')) { + $bighash{'encrypted_'.$id} eq $env{'request.enc'}) { $okay=1; } } @@ -10033,7 +9578,6 @@ sub get_dns { while (%alldns) { my ($dns) = keys(%alldns); my $ua=new LWP::UserAgent; - $ua->timeout(30); my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); my $response=$ua->request($request); delete($alldns{$dns}); @@ -10117,21 +9661,14 @@ sub get_dns { my %libserv; my $loaded; my %name_to_host; - my %internetdom; - my %LC_dns_serv; sub parse_hosts_tab { my ($file) = @_; foreach my $configline (@$file) { next if ($configline =~ /^(\#|\s*$ )/x); - chomp($configline); - if ($configline =~ /^\^/) { - if ($configline =~ /^\^([\w.\-]+)/) { - $LC_dns_serv{$1} = 1; - } - next; - } - my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); + next if ($configline =~ /^\^/); + chomp($configline); + my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline); $name=~s/\s//g; if ($id && $domain && $role && $name) { $hostname{$id}=$name; @@ -10147,9 +9684,6 @@ sub get_dns { } else { $protocol{$id} = 'http'; } - if (defined($intdom)) { - $internetdom{$id} = $intdom; - } } } } @@ -10212,7 +9746,7 @@ sub get_dns { } sub unique_library { - #2x reverse removes all hostnames that appear more than once + #2x reverse removes all hostnames that appear more than once my %unique = reverse &all_library(); return reverse %unique; } @@ -10242,7 +9776,7 @@ sub get_dns { sub get_unique_servers { my %unique = reverse &get_servers(@_); - return reverse %unique; + return reverse %unique; } sub host_domain { @@ -10259,21 +9793,6 @@ sub get_dns { my @uniq = grep(!$seen{$_}++, values(%hostdom)); return @uniq; } - - sub internet_dom { - &load_hosts_tab() if (!$loaded); - - my ($lonid) = @_; - return $internetdom{$lonid}; - } - - sub is_LC_dns { - &load_hosts_tab() if (!$loaded); - - my ($hostname) = @_; - return exists($LC_dns_serv{$hostname}); - } - } { @@ -10391,40 +9910,6 @@ sub get_dns { return undef; } - sub get_internet_names { - my ($lonid) = @_; - return if ($lonid eq ''); - my ($idnref,$cached)= - &Apache::lonnet::is_cached_new('internetnames',$lonid); - if ($cached) { - return $idnref; - } - my $ip = &get_host_ip($lonid); - my @hosts = &get_hosts_from_ip($ip); - my %iphost = &get_iphost(); - my (@idns,%seen); - foreach my $id (@hosts) { - my $dom = &host_domain($id); - my $prim_id = &domain($dom,'primary'); - my $prim_ip = &get_host_ip($prim_id); - next if ($seen{$prim_ip}); - if (ref($iphost{$prim_ip}) eq 'ARRAY') { - foreach my $id (@{$iphost{$prim_ip}}) { - my $intdom = &internet_dom($id); - unless (grep(/^\Q$intdom\E$/,@idns)) { - push(@idns,$intdom); - } - } - } - $seen{$prim_ip} = 1; - } - return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60); - } - -} - -sub all_loncaparevs { - return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10); } BEGIN { @@ -10502,69 +9987,6 @@ BEGIN { close($config); } -# ---------------------------------------------------------- Read loncaparev table -{ - if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { - while (my $configline=<$config>) { - chomp($configline); - my ($hostid,$loncaparev)=split(/:/,$configline); - $loncaparevs{$hostid}=$loncaparev; - } - close($config); - } - } -} - -# ---------------------------------------------------------- Read serverhostID table -{ - if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { - while (my $configline=<$config>) { - chomp($configline); - my ($name,$id)=split(/:/,$configline); - $serverhomeIDs{$name}=$id; - } - close($config); - } - } -} - -{ - my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml'; - if (-e $file) { - my $parser = HTML::LCParser->new($file); - while (my $token = $parser->get_token()) { - if ($token->[0] eq 'S') { - my $item = $token->[1]; - my $name = $token->[2]{'name'}; - my $value = $token->[2]{'value'}; - if ($item ne '' && $name ne '' && $value ne '') { - my $release = $parser->get_text(); - $release =~ s/(^\s*|\s*$ )//gx; - $needsrelease{$item.':'.$name.':'.$value} = $release; - } - } - } - } -} - -# ---------------------------------------------------------- Read managers table -{ - if (-e "$perlvar{'lonTabDir'}/managers.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { - while (my $configline=<$config>) { - chomp($configline); - next if ($configline =~ /^\#/); - if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) { - $managerstab{$configline} = 1; - } - } - close($config); - } - } -} - # ------------- set up temporary directory { $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; @@ -10795,14 +10217,9 @@ authentication scheme =item * X -B: try to +B: try to authenticate user from domain's lib servers (first use the current one). C<$upass> should be the users password. -$checkdefauth is optional (value is 1 if a check should be made to - authenticate user using default authentication method, and allow - account creation if username does not have account in the domain). -$clientcancheckhost is optional (value is 1 if checking whether the - server can host will occur on the client side in lonauth.pm). =item * X @@ -11458,11 +10875,11 @@ splitting on '&', supports elements that =head2 Logging Routines +=over 4 + These routines allow one to make log messages in the lonnet.log and lonnet.perm logfiles. -=over 4 - =item * logtouch() : make sure the logfile, lonnet.log, exists @@ -11551,10 +10968,8 @@ userfileupload(): main rotine for puttin filename, and the contents of the file to create/modifed exist the filename is in $env{'form.'.$formname.'.filename'} and the contents of the file is located in $env{'form.'.$formname} - context - if coursedoc, store the file in the course of the active role - of the current user; - if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp - if 'canceloverwrite': delete file in tmp/overwrites directory + coursedoc - if true, store the file in the course of the active role + of the current user subdir - required - subdirectory to put the file in under ../userfiles/ if undefined, it will be placed in "unknown" @@ -11576,29 +10991,16 @@ returns: the new clean filename =item * -finishuserfileupload(): routine that creates and sends the file to +finishuserfileupload(): routine that creaes and sends the file to userspace, probably shouldn't be called directly docuname: username or courseid of destination for the file docudom: domain of user/course of destination for the file formname: same as for userfileupload() - fname: filename (including subdirectories) for the file - parser: if 'parse', will parse (html) file to extract references to objects, links etc. - allfiles: reference to hash used to store objects found by parser - codebase: reference to hash used for codebases of java objects found by parser - thumbwidth: width (pixels) of thumbnail to be created for uploaded image - thumbheight: height (pixels) of thumbnail to be created for uploaded image - resizewidth: width to be used to resize image using resizeImage from ImageMagick - resizeheight: height to be used to resize image using resizeImage from ImageMagick - context: if 'overwrite', will move the uploaded file from its temporary location to - userfiles to facilitate overwriting a previously uploaded file with same name. - mimetype: reference to scalar to accommodate mime type determined - from File::MMagic if $parser = parse. + fname: filename (inculding subdirectories) for the file returns either the url of the uploaded file (/uploaded/....) if successful - and /adm/notfound.html if unsuccessful (or an error message if context - was 'overwrite'). - + and /adm/notfound.html if unsuccessful =item * 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.