--- loncom/lonnet/perl/lonnet.pm 2019/08/19 17:35:34 1.1172.2.111 +++ loncom/lonnet/perl/lonnet.pm 2016/01/31 21:25:57 1.1300 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.111 2019/08/19 17:35:34 raeburn Exp $ +# $Id: lonnet.pm,v 1.1300 2016/01/31 21:25:57 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -74,9 +74,11 @@ use strict; use LWP::UserAgent(); use HTTP::Date; use Image::Magick; -use CGI::Cookie; -use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex + +use Encode; + +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease %managerstab); @@ -99,7 +101,6 @@ use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; use LONCAPA::lonmetadata; use LONCAPA::Lond; -use LONCAPA::transliterate; use File::Copy; @@ -111,6 +112,7 @@ require Exporter; our @ISA = qw (Exporter); our @EXPORT = qw(%env); + # ------------------------------------ Logging (parameters, docs, slots, roles) { my $logid; @@ -125,26 +127,26 @@ our @EXPORT = qw(%env); $logid ++; my $now = time(); my $id=$now.'00000'.$$.'00000'.$logid; - my $logentry = { - $id => { - 'exe_uname' => $env{'user.name'}, - 'exe_udom' => $env{'user.domain'}, - 'exe_time' => $now, - 'exe_ip' => $ENV{'REMOTE_ADDR'}, - 'delflag' => $delflag, - 'logentry' => $storehash, - 'uname' => $uname, - 'udom' => $udom, - } + my $logentry = { + $id => { + 'exe_uname' => $env{'user.name'}, + 'exe_udom' => $env{'user.domain'}, + 'exe_time' => $now, + 'exe_ip' => $ENV{'REMOTE_ADDR'}, + 'delflag' => $delflag, + 'logentry' => $storehash, + 'uname' => $uname, + 'udom' => $udom, + } }; - return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); + return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); } } sub logtouch { my $execdir=$perlvar{'lonDaemons'}; unless (-e "$execdir/logs/lonnet.log") { - open(my $fh,">>","$execdir/logs/lonnet.log"); + open(my $fh,">>$execdir/logs/lonnet.log"); close $fh; } my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; @@ -156,7 +158,7 @@ sub logthis { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - if (open(my $fh,">>","$execdir/logs/lonnet.log")) { + if (open(my $fh,">>$execdir/logs/lonnet.log")) { my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. print $fh $logstring; close($fh); @@ -169,7 +171,7 @@ sub logperm { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) { + if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { print $fh "$now:$message:$local\n"; close($fh); } @@ -358,7 +360,8 @@ sub remote_devalidate_cache { my $items; return unless (ref($cachekeys) eq 'ARRAY'); my $cachestr = join('&',@{$cachekeys}); - return &reply('devalidatecache:'.&escape($cachestr),$lonhost); + my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost); + return $response; } # -------------------------------------------------- Non-critical communication @@ -390,7 +393,7 @@ sub subreply { } else { &create_connection(&hostname($server),$server); } - sleep(0.1); # Try again later if failed connection. + sleep(0.1); # Try again later if failed connection. } my $answer; if ($client) { @@ -409,26 +412,8 @@ sub reply { unless (defined(&hostname($server))) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { - my $logged = $cmd; - if ($cmd =~ /^encrypt:([^:]+):/) { - my $subcmd = $1; - if (($subcmd eq 'auth') || ($subcmd eq 'passwd') || - ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || - ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) { - (undef,undef,my @rest) = split(/:/,$cmd); - if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) { - splice(@rest,2,1,'Hidden'); - } elsif ($subcmd eq 'passwd') { - splice(@rest,2,2,('Hidden','Hidden')); - } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || - ($subcmd eq 'autoexportgrades')) { - splice(@rest,3,1,'Hidden'); - } - $logged = join(':',('encrypt:'.$subcmd,@rest)); - } - } - &logthis("WARNING:". - " $logged to $server returned $answer"); + &logthis("WARNING:". + " $cmd to $server returned $answer"); } return $answer; } @@ -456,14 +441,14 @@ sub reconlonc { &logthis("Trying to reconnect lonc"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; - if (open(my $fh,"<",$loncfile)) { + if (open(my $fh,"<$loncfile")) { my $loncpid=<$fh>; chomp($loncpid); if (kill 0 => $loncpid) { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; sleep 1; - } else { + } else { &logthis( "WARNING:". " lonc at pid $loncpid not responding, giving up"); @@ -496,7 +481,7 @@ sub critical { $dumpcount++; { my $dfh; - if (open($dfh,">",$dfilename)) { + if (open($dfh,">$dfilename")) { print $dfh "$cmd\n"; close($dfh); } @@ -505,7 +490,7 @@ sub critical { my $wcmd=''; { my $dfh; - if (open($dfh,"<",$dfilename)) { + if (open($dfh,"<$dfilename")) { $wcmd=<$dfh>; close($dfh); } @@ -621,52 +606,22 @@ sub transfer_profile_to_env { # ---------------------------------------------------- Check for valid session sub check_for_valid_session { - my ($r,$name,$userhashref,$domref) = @_; + my ($r,$name,$userhashref) = @_; my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); - my ($lonidsdir,$linkname,$pubname,$secure,$lonid); - if ($name eq 'lonDAV') { - $lonidsdir=$r->dir_config('lonDAVsessDir'); - } else { - $lonidsdir=$r->dir_config('lonIDsDir'); - if ($name eq '') { - $name = 'lonID'; - } - } - if ($name eq 'lonID') { - $secure = 'lonSID'; - $linkname = 'lonLinkID'; - $pubname = 'lonPubID'; - if (exists($cookies{$secure})) { - $lonid=$cookies{$secure}; - } elsif (exists($cookies{$name})) { - $lonid=$cookies{$name}; - } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) { - $lonid=$cookies{$linkname}; - } elsif (exists($cookies{$pubname})) { - $lonid=$cookies{$pubname}; - } - } else { - $lonid=$cookies{$name}; + if ($name eq '') { + $name = 'lonID'; } + my $lonid=$cookies{$name}; return undef if (!$lonid); my $handle=&LONCAPA::clean_handle($lonid->value); - if (-l "$lonidsdir/$handle.id") { - my $link = readlink("$lonidsdir/$handle.id"); - if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { - $handle = $1; - } - } - if (!-e "$lonidsdir/$handle.id") { - if ((ref($domref)) && ($name eq 'lonID') && - ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { - my ($possuname,$possudom,$possuhome) = ($1,$2,$3); - if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { - $$domref = $possudom; - } - } - return undef; + my $lonidsdir; + if ($name eq 'lonDAV') { + $lonidsdir=$r->dir_config('lonDAVsessDir'); + } else { + $lonidsdir=$r->dir_config('lonIDsDir'); } + return undef if (!-e "$lonidsdir/$handle.id"); my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); return undef if (!$opened); @@ -680,7 +635,6 @@ sub check_for_valid_session { if (!defined($disk_env{'user.name'}) || !defined($disk_env{'user.domain'})) { - untie(%disk_env); return undef; } @@ -688,7 +642,6 @@ sub check_for_valid_session { $userhashref->{'name'} = $disk_env{'user.name'}; $userhashref->{'domain'} = $disk_env{'user.domain'}; } - untie(%disk_env); return $handle; } @@ -713,37 +666,6 @@ sub timed_flock { } } -sub get_sessionfile_vars { - my ($handle,$lonidsdir,$storearr) = @_; - my %returnhash; - unless (ref($storearr) eq 'ARRAY') { - return %returnhash; - } - if (-l "$lonidsdir/$handle.id") { - my $link = readlink("$lonidsdir/$handle.id"); - if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { - $handle = $1; - } - } - if ((-e "$lonidsdir/$handle.id") && - ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { - my ($possuname,$possudom,$possuhome) = ($1,$2,$3); - if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { - if (open(my $idf,'+<',"$lonidsdir/$handle.id")) { - flock($idf,LOCK_SH); - if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", - &GDBM_READER(),0640)) { - foreach my $item (@{$storearr}) { - $returnhash{$item} = $disk_env{$item}; - } - untie(%disk_env); - } - } - } - } - return %returnhash; -} - # ---------------------------------------------------------- Append Environment sub appenv { @@ -769,19 +691,16 @@ sub appenv { $env{$key}=$newenv->{$key}; } } - my $lonids = $perlvar{'lonIDsDir'}; - if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) { - my $opened = open(my $env_file,'+<',$env{'user.environment'}); - if ($opened - && &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; - } - untie(%disk_env); - } + my $opened = open(my $env_file,'+<',$env{'user.environment'}); + if ($opened + && &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; + } + untie(%disk_env); } } return 'ok'; @@ -1025,75 +944,6 @@ sub find_existing_session { return; } -# check if user's browser sent load balancer cookie and server still has session -# and is not overloaded. -sub check_for_balancer_cookie { - my ($r,$update_mtime) = @_; - my ($otherserver,$cookie); - my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); - if (exists($cookies{'balanceID'})) { - my $balid = $cookies{'balanceID'}; - $cookie=&LONCAPA::clean_handle($balid->value); - my $balancedir=$r->dir_config('lonBalanceDir'); - if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) { - if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) { - my ($possudom,$possuname) = ($1,$2); - my $has_session = 0; - if ((&domain($possudom) ne '') && - (&homeserver($possuname,$possudom) ne 'no_host')) { - my $try_server; - my $opened = open(my $idf,'+<',"$balancedir/$cookie.id"); - if ($opened) { - flock($idf,LOCK_SH); - while (my $line = <$idf>) { - chomp($line); - if (&hostname($line) ne '') { - $try_server = $line; - last; - } - } - close($idf); - if (($try_server) && - (&has_user_session($try_server,$possudom,$possuname))) { - my $lowest_load = 30000; - ($otherserver,$lowest_load) = - &compare_server_load($try_server,undef,$lowest_load); - if ($otherserver ne '' && $lowest_load < 100) { - $has_session = 1; - } else { - undef($otherserver); - } - } - } - } - if ($has_session) { - if ($update_mtime) { - my $atime = my $mtime = time; - utime($atime,$mtime,"$balancedir/$cookie.id"); - } - } else { - unlink("$balancedir/$cookie.id"); - } - } - } - } - return ($otherserver,$cookie); -} - -sub delbalcookie { - my ($cookie,$balancer) =@_; - if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { - my ($udom,$uname) = ($1,$2); - my $uprimary_id = &domain($udom,'primary'); - my $uintdom = &internet_dom($uprimary_id); - my $intdom = &internet_dom($balancer); - my $serverhomedom = &host_domain($balancer); - if (($uintdom ne '') && ($uintdom eq $intdom)) { - return &reply("delbalcookie:$cookie",$balancer); - } - } -} - # -------------------------------- ask if server already has a session for user sub has_user_session { my ($lonid,$udom,$uname) = @_; @@ -1125,12 +975,12 @@ sub choose_server { } } foreach my $lonhost (keys(%servers)) { - my $loginvia; if ($skiploadbal) { if (ref($balancers) eq 'HASH') { next if (exists($balancers->{$lonhost})); } - } + } + my $loginvia; if ($checkloginvia) { $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; if ($loginvia) { @@ -1157,7 +1007,7 @@ sub choose_server { if ($login_host ne '') { $hostname = &hostname($login_host); } - return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); + return ($login_host,$hostname,$portal_path,$isredirect); } # --------------------------------------------- Try to change a user's password @@ -1429,16 +1279,16 @@ sub get_lonbalancer_config { } sub check_loadbalancing { - my ($uname,$udom,$caller) = @_; + my ($uname,$udom) = @_; my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, - $rule_in_effect,$offloadto,$otherserver,$setcookie); + $rule_in_effect,$offloadto,$otherserver); my $lonhost = $perlvar{'lonHostID'}; my @hosts = ¤t_machine_ids(); my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); my $intdom = &Apache::lonnet::internet_dom($lonhost); my $serverhomedom = &host_domain($lonhost); - my $domneedscache; + my $cachetime = 60*60*24; if (($uintdom ne '') && ($uintdom eq $intdom)) { @@ -1453,12 +1303,10 @@ sub check_loadbalancing { &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); - } else { - $domneedscache = $dom_in_use; } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules,$setcookie) = + ($is_balancer,$currtargets,$currrules) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1513,13 +1361,11 @@ sub check_loadbalancing { my %domconfig = &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { - $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime); - } else { - $domneedscache = $serverhomedom; + $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules,$setcookie) = + ($is_balancer,$currtargets,$currrules) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1535,21 +1381,12 @@ sub check_loadbalancing { $is_balancer = 1; $offloadto = &this_host_spares($dom_in_use); } - unless (defined($cached)) { - $domneedscache = $serverhomedom; - } } } else { if ($perlvar{'lonBalancer'} eq 'yes') { $is_balancer = 1; $offloadto = &this_host_spares($dom_in_use); } - unless (defined($cached)) { - $domneedscache = $serverhomedom; - } - } - if ($domneedscache) { - &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); } if ($is_balancer) { my $lowest_load = 30000; @@ -1580,27 +1417,23 @@ sub check_loadbalancing { } } } - unless ($caller eq 'login') { - if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { - $is_balancer = 0; - if ($uname ne '' && $udom ne '') { - if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { - &appenv({'user.loadbalexempt' => $lonhost, - 'user.loadbalcheck.time' => time}); - } + if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { + $is_balancer = 0; + if ($uname ne '' && $udom ne '') { + if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { + + &appenv({'user.loadbalexempt' => $lonhost, + 'user.loadbalcheck.time' => time}); } } } - unless ($homeintdom) { - undef($setcookie); - } } - return ($is_balancer,$otherserver,$setcookie); + return ($is_balancer,$otherserver); } sub check_balancer_result { my ($result,@hosts) = @_; - my ($is_balancer,$currtargets,$currrules,$setcookie); + my ($is_balancer,$currtargets,$currrules); if (ref($result) eq 'HASH') { if ($result->{'lonhost'} ne '') { my $currbalancer = $result->{'lonhost'}; @@ -1616,13 +1449,12 @@ sub check_balancer_result { $is_balancer = 1; $currrules = $result->{$key}{'rules'}; $currtargets = $result->{$key}{'targets'}; - $setcookie = $result->{$key}{'cookie'}; last; } } } } - return ($is_balancer,$currtargets,$currrules,$setcookie); + return ($is_balancer,$currtargets,$currrules); } sub get_loadbalancer_targets { @@ -1719,17 +1551,33 @@ sub homeserver { return 'no_host'; } -# ------------------------------------- Find the usernames behind a list of IDs +# ----- Find the usernames behind a list of student/employee IDs or clicker IDs sub idget { - my ($udom,@ids)=@_; + my ($udom,$idsref,$namespace)=@_; my %returnhash=(); + my @ids=(); + if (ref($idsref) eq 'ARRAY') { + @ids = @{$idsref}; + } else { + return %returnhash; + } + if ($namespace eq '') { + $namespace = 'ids'; + } my %servers = &get_servers($udom,'library'); foreach my $tryserver (keys(%servers)) { my $idlist=join('&', map { &escape($_); } @ids); - $idlist=~tr/A-Z/a-z/; - my $reply=&reply("idget:$udom:".$idlist,$tryserver); + if ($namespace eq 'ids') { + $idlist=~tr/A-Z/a-z/; + } + my $reply; + if ($namespace eq 'ids') { + $reply=&reply("idget:$udom:".$idlist,$tryserver); + } else { + $reply=&reply("getdom:$udom:$namespace:$idlist",$tryserver); + } my @answer=(); if (($reply ne 'con_lost') && ($reply!~/^error\:/)) { @answer=split(/\&/,$reply); @@ -1738,9 +1586,9 @@ sub idget { for ($i=0;$i<=$#ids;$i++) { if ($answer[$i]) { $returnhash{$ids[$i]}=&unescape($answer[$i]); - } + } } - } + } return %returnhash; } @@ -1755,60 +1603,141 @@ sub idrget { return %returnhash; } -# ------------------------------- Store away a list of names and associated IDs +# Store away a list of names and associated student/employee IDs or clicker IDs sub idput { - my ($udom,%ids)=@_; + my ($udom,$idsref,$uhom,$namespace)=@_; my %servers=(); + my %ids=(); + my %byid = (); + if (ref($idsref) eq 'HASH') { + %ids=%{$idsref}; + } + if ($namespace eq '') { + $namespace = 'ids'; + } foreach my $uname (keys(%ids)) { &cput('environment',{'id'=>$ids{$uname}},$udom,$uname); - my $uhom=&homeserver($uname,$udom); + if ($uhom eq '') { + $uhom=&homeserver($uname,$udom); + } if ($uhom ne 'no_host') { - my $id=&escape($ids{$uname}); - $id=~tr/A-Z/a-z/; my $esc_unam=&escape($uname); - if ($servers{$uhom}) { - $servers{$uhom}.='&'.$id.'='.$esc_unam; + if ($namespace eq 'ids') { + my $id=&escape($ids{$uname}); + $id=~tr/A-Z/a-z/; + my $esc_unam=&escape($uname); + $servers{$uhom}.=$id.'='.$esc_unam.'&'; } else { - $servers{$uhom}=$id.'='.$esc_unam; + my @currids = split(/,/,$ids{$uname}); + foreach my $id (@currids) { + $byid{$uhom}{$id} .= $uname.','; + } + } + } + } + if ($namespace eq 'clickers') { + foreach my $server (keys(%byid)) { + if (ref($byid{$server}) eq 'HASH') { + foreach my $id (keys(%{$byid{$server}})) { + $byid{$server} =~ s/,$//; + $servers{$uhom}.=&escape($id).'='.&escape($byid{$server}).'&'; + } } } } foreach my $server (keys(%servers)) { - &critical('idput:'.$udom.':'.$servers{$server},$server); + $servers{$server} =~ s/\&$//; + if ($namespace eq 'ids') { + &critical('idput:'.$udom.':'.$servers{$server},$server); + } else { + &critical('updateclickers:'.$udom.':add:'.$servers{$server},$server); + } } } -# ---------------------------------------- Delete unwanted IDs from ids.db file +# ------------- Delete unwanted student/employee IDs or clicker IDs from domain sub iddel { - my ($udom,$idshashref,$uhome)=@_; + my ($udom,$idshashref,$uhome,$namespace)=@_; my %result=(); - unless (ref($idshashref) eq 'HASH') { + my %ids=(); + my %byid = (); + if (ref($idshashref) eq 'HASH') { + %ids=%{$idshashref}; + } else { return %result; } + if ($namespace eq '') { + $namespace = 'ids'; + } my %servers=(); - while (my ($id,$uname) = each(%{$idshashref})) { - my $uhom; - if ($uhome) { - $uhom = $uhome; - } else { - $uhom=&homeserver($uname,$udom); - } - if ($uhom ne 'no_host') { - if ($servers{$uhom}) { + while (my ($id,$unamestr) = each(%ids)) { + if ($namespace eq 'ids') { + my $uhom = $uhome; + if ($uhom eq '') { + $uhom=&homeserver($unamestr,$udom); + } + if ($uhom ne 'no_host') { $servers{$uhom}.='&'.&escape($id); - } else { - $servers{$uhom}=&escape($id); + } + } else { + my @curritems = split(/,/,$ids{$id}); + foreach my $uname (@curritems) { + my $uhom = $uhome; + if ($uhom eq '') { + $uhom=&homeserver($uname,$udom); + } + if ($uhom ne 'no_host') { + $byid{$uhom}{$id} .= $uname.','; + } + } + } + } + if ($namespace eq 'clickers') { + foreach my $server (keys(%byid)) { + if (ref($byid{$server}) eq 'HASH') { + foreach my $id (keys(%{$byid{$server}})) { + $byid{$server}{$id} =~ s/,$//; + $servers{$server}.=&escape($id).'='.&escape($byid{$server}{$id}).'&'; + } } } } foreach my $server (keys(%servers)) { - $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome); + $servers{$server} =~ s/\&$//; + if ($namespace eq 'ids') { + $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome); + } elsif ($namespace eq 'clickers') { + $result{$server} = &critical('updateclickers:'.$udom.':del:'.$servers{$server},$server); + } } return %result; } +# ----- Update clicker ID-to-username look-ups in clickers.db on library server + +sub updateclickers { + my ($udom,$action,$idshashref,$uhome,$critical) = @_; + my %clickers; + if (ref($idshashref) eq 'HASH') { + %clickers=%{$idshashref}; + } else { + return; + } + my $items=''; + foreach my $item (keys(%clickers)) { + $items.=&escape($item).'='.&escape($clickers{$item}).'&'; + } + $items=~s/\&$//; + my $request = "updateclickers:$udom:$action:$items"; + if ($critical) { + return &critical($request,$uhome); + } else { + return &reply($request,$uhome); + } +} + # ------------------------------dump from db file owned by domainconfig user sub dump_dom { my ($namespace, $udom, $regexp) = @_; @@ -1966,7 +1895,7 @@ sub retrieve_inst_usertypes { sub is_domainimage { my ($url) = @_; - if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) { + if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) { if (&domain($1) ne '') { return '1'; } @@ -1987,7 +1916,7 @@ sub inst_directory_query { &escape($srch->{'srchtype'}),$homeserver); my $host=&hostname($homeserver); if ($queryid !~/^\Q$host\E\_/) { - &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom); + &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); return; } my $response = &get_query_reply($queryid); @@ -2111,7 +2040,7 @@ sub get_multiple_instusers { my ($udom,$users,$caller) = @_; my ($outcome,$results); if (ref($users) eq 'HASH') { - my $count = keys(%{$users}); + my $count = keys(%{$users}); my $requested = &freeze_escape($users); my $homeserver = &domain($udom,'primary'); if ($homeserver ne '') { @@ -2155,7 +2084,7 @@ sub get_multiple_instusers { } else { ($outcome,my $userdata) = split(/=/,$response,2); if ($outcome eq 'ok') { - $results = &thaw_unescape($userdata); + $results = &thaw_unescape($userdata); } } } @@ -2260,8 +2189,7 @@ sub get_domain_defaults { 'requestcourses','inststatus', 'coursedefaults','usersessions', 'requestauthor','selfenrollment', - 'coursecategories','autoenroll', - 'helpsettings'],$domain); + 'coursecategories'],$domain); my @coursetypes = ('official','unofficial','community','textbook'); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; @@ -2270,9 +2198,6 @@ sub get_domain_defaults { $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; - $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; - $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; - $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -2308,6 +2233,7 @@ sub get_domain_defaults { } } if (ref($domconfig{'coursedefaults'}) eq 'HASH') { + $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'}; $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'}; $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'}; if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') { @@ -2324,8 +2250,8 @@ sub get_domain_defaults { } if ($domdefaults{'postsubmit'} eq 'on') { if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') { - $domdefaults{$type.'postsubtimeout'} = - $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; + $domdefaults{$type.'postsubtimeout'} = + $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; } } } @@ -2339,9 +2265,6 @@ sub get_domain_defaults { } elsif ($domconfig{'coursedefaults'}{'canclone'}) { $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; } - if ($domconfig{'coursedefaults'}{'texengine'}) { - $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'}; - } } if (ref($domconfig{'usersessions'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { @@ -2385,85 +2308,17 @@ sub get_domain_defaults { if (ref($domconfig{'coursecategories'}) eq 'HASH') { $domdefaults{'catauth'} = 'std'; $domdefaults{'catunauth'} = 'std'; - if ($domconfig{'coursecategories'}{'auth'}) { + if ($domconfig{'coursecategories'}{'auth'}) { $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'}; } if ($domconfig{'coursecategories'}{'unauth'}) { $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; } } - if (ref($domconfig{'autoenroll'}) eq 'HASH') { - $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; - } - if (ref($domconfig{'helpsettings'}) eq 'HASH') { - $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'}; - if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') { - $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; - } - } &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); return %domdefaults; } -sub get_dom_cats { - my ($dom) = @_; - return unless (&domain($dom)); - my ($cats,$cached)=&is_cached_new('cats',$dom); - unless (defined($cached)) { - my %domconfig = &get_dom('configuration',['coursecategories'],$dom); - if (ref($domconfig{'coursecategories'}) eq 'HASH') { - if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') { - %{$cats} = %{$domconfig{'coursecategories'}{'cats'}}; - } else { - $cats = {}; - } - } else { - $cats = {}; - } - &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600); - } - return $cats; -} - -sub get_dom_instcats { - my ($dom) = @_; - return unless (&domain($dom)); - my ($instcats,$cached)=&is_cached_new('instcats',$dom); - unless (defined($cached)) { - my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order); - my $totcodes = &retrieve_instcodes(\%coursecodes,$dom); - if ($totcodes > 0) { - my $caller = 'global'; - if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes, - \@codetitles,\%cat_titles,\%cat_order) eq 'ok') { - $instcats = { - codes => \%codes, - codetitles => \@codetitles, - cat_titles => \%cat_titles, - cat_order => \%cat_order, - }; - &do_cache_new('instcats',$dom,$instcats,3600); - } - } - } - return $instcats; -} - -sub retrieve_instcodes { - my ($coursecodes,$dom) = @_; - my $totcodes; - my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course'); - foreach my $course (keys(%courses)) { - if (ref($courses{$course}) eq 'HASH') { - if ($courses{$course}{'inst_code'} ne '') { - $$coursecodes{$course} = $courses{$course}{'inst_code'}; - $totcodes ++; - } - } - } - return $totcodes; -} - # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -2700,25 +2555,21 @@ sub make_key { sub devalidate_cache_new { my ($name,$id,$debug) = @_; if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } - my $remembered_id=$name.':'.$id; $id=&make_key($name,$id); $memcache->delete($id); - delete($remembered{$remembered_id}); - delete($accessed{$remembered_id}); + delete($remembered{$id}); + delete($accessed{$id}); } sub is_cached_new { my ($name,$id,$debug) = @_; - my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for - # keys in %remembered hash, which persists for - # duration of request (no restriction on key length). - if (exists($remembered{$remembered_id})) { - if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); } - $accessed{$remembered_id}=[&gettimeofday()]; + $id=&make_key($name,$id); + if (exists($remembered{$id})) { + if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); } + $accessed{$id}=[&gettimeofday()]; $hits++; - return ($remembered{$remembered_id},1); + return ($remembered{$id},1); } - $id=&make_key($name,$id); my $value = $memcache->get($id); if (!(defined($value))) { if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } @@ -2728,14 +2579,13 @@ sub is_cached_new { if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } $value=undef; } - &make_room($remembered_id,$value,$debug); + &make_room($id,$value,$debug); if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } return ($value,1); } sub do_cache_new { my ($name,$id,$value,$time,$debug) = @_; - my $remembered_id=$name.':'.$id; $id=&make_key($name,$id); my $setvalue=$value; if (!defined($setvalue)) { @@ -2751,17 +2601,17 @@ sub do_cache_new { $memcache->disconnect_all(); } # need to make a copy of $value - &make_room($remembered_id,$value,$debug); + &make_room($id,$value,$debug); return $value; } sub make_room { - my ($remembered_id,$value,$debug)=@_; + my ($id,$value,$debug)=@_; - $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value) + $remembered{$id}= (ref($value)) ? &Storable::dclone($value) : $value; if ($to_remember<0) { return; } - $accessed{$remembered_id}=[&gettimeofday()]; + $accessed{$id}=[&gettimeofday()]; if (scalar(keys(%remembered)) <= $to_remember) { return; } my $to_kick; my $max_time=0; @@ -3048,51 +2898,32 @@ sub absolute_url { sub ssi { my ($fn,%form)=@_; - my ($request,$response); + my $ua=new LWP::UserAgent; + my $request; $form{'no_update_last_known'}=1; &Apache::lonenc::check_encrypt(\$fn); if (%form) { $request=new HTTP::Request('POST',&absolute_url().$fn); - $request->content(join('&',map { + $request->content(join('&',map { my $name = escape($_); - "$name=" . ( ref($form{$_}) eq 'ARRAY' - ? join("&$name=", map {escape($_) } @{$form{$_}}) - : &escape($form{$_}) ); + "$name=" . ( ref($form{$_}) eq 'ARRAY' + ? join("&$name=", map {escape($_) } @{$form{$_}}) + : &escape($form{$_}) ); } keys(%form))); } else { $request=new HTTP::Request('GET',&absolute_url().$fn); } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); + my $response= $ua->request($request); + my $content = $response->content; + - if (($env{'request.course.id'}) && - ($form{'grade_courseid'} eq $env{'request.course.id'}) && - ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') && - ($form{'grade_symb'} ne '') && - (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}. - ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { - if (LWP::UserAgent->VERSION >= 5.834) { - my $ua=new LWP::UserAgent; - $ua->local_address('127.0.0.1'); - $response = $ua->request($request); - } else { - { - require LWP::Protocol::http; - local @LWP::Protocol::http::EXTRA_SOCK_OPTS = (LocalAddr => '127.0.0.1'); - my $ua=new LWP::UserAgent; - $response = $ua->request($request); - @LWP::Protocol::http::EXTRA_SOCK_OPTS = (); - } - } - } else { - my $ua=new LWP::UserAgent; - $response = $ua->request($request); - } if (wantarray) { - return ($response->content, $response); + return ($content, $response); } else { - return $response->content; + return $content; } } @@ -3108,72 +2939,6 @@ sub externalssi { } } -# If the local copy of a replicated resource is outdated, trigger a -# connection from the homeserver to flush the delayed queue. If no update -# happens, remove local copies of outdated resource (and corresponding -# metadata file). - -sub remove_stale_resfile { - my ($url) = @_; - my $removed; - if ($url=~m{^/res/($match_domain)/($match_username)/}) { - my $audom = $1; - my $auname = $2; - unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) { - my $homeserver = &homeserver($auname,$audom); - unless (($homeserver eq 'no_host') || - (grep { $_ eq $homeserver } ¤t_machine_ids())) { - my $fname = &filelocation('',$url); - if (-e $fname) { - my $ua=new LWP::UserAgent; - $ua->timeout(5); - my $protocol = $protocol{$homeserver}; - $protocol = 'http' if ($protocol ne 'https'); - my $hostname = &hostname($homeserver); - if ($hostname) { - my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url); - my $request=new HTTP::Request('HEAD',$uri); - my $response=$ua->request($request); - if ($response->is_success()) { - my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') ); - my $locmodtime = (stat($fname))[9]; - if ($locmodtime < $remmodtime) { - my $stale; - my $answer = &reply('pong',$homeserver); - if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) { - sleep(0.2); - $locmodtime = (stat($fname))[9]; - if ($locmodtime < $remmodtime) { - my $posstransfer = $fname.'.in.transfer'; - if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) { - $removed = 1; - } else { - $stale = 1; - } - } else { - $removed = 1; - } - } else { - $stale = 1; - } - if ($stale) { - unlink($fname); - if ($uri!~/\.meta$/) { - unlink($fname.'.meta'); - } - &reply("unsub:$fname",$homeserver); - $removed = 1; - } - } - } - } - } - } - } - } - return $removed; -} - # -------------------------------- Allow a /uploaded/ URI to be vouched for sub allowuploaded { @@ -3190,7 +2955,7 @@ sub allowuploaded { # # Determine if the current user should be able to edit a particular resource, # when viewing in course context. -# (a) When viewing resource used to determine if "Edit" item is included in +# (a) When viewing resource used to determine if "Edit" item is included in # Functions. # (b) When displaying folder contents in course editor, used to determine if # "Edit" link will be displayed alongside resource. @@ -3198,12 +2963,12 @@ sub allowuploaded { # input: six args -- filename (decluttered), course number, course domain, # url, symb (if registered) and group (if this is a group # item -- e.g., bulletin board, group page etc.). -# output: array of five scalars -- +# output: array of five scalars -- # $cfile -- url for file editing if editable on current server # $home -- homeserver of resource (i.e., for author if published, # or course if uploaded.). # $switchserver -- 1 if server switch will be needed. -# $forceedit -- 1 if icon/link should be to go to edit mode +# $forceedit -- 1 if icon/link should be to go to edit mode # $forceview -- 1 if icon/link should be to go to view mode # @@ -3292,7 +3057,7 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } elsif (($resurl ne '') && (&is_on_map($resurl))) { + } elsif (($resurl ne '') && (&is_on_map($resurl))) { if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3312,6 +3077,14 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; + } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) { + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + } else { + $forceedit = 1; + } + $cfile = $resurl; } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3323,7 +3096,7 @@ sub can_edit_resource { } } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') { my $template = '/res/lib/templates/simpleproblem.problem'; - if (&is_on_map($template)) { + if (&is_on_map($template)) { $incourse = 1; $forceview = 1; $cfile = $template; @@ -3336,6 +3109,14 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; + } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + } else { + $forceedit = 1; + } + $cfile = $resurl; } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { $incourse = 1; $forceview = 1; @@ -3345,8 +3126,13 @@ sub can_edit_resource { $cfile = &clutter($res); } else { $cfile = $env{'form.suppurl'}; - $cfile =~ s{^http://}{}; - $cfile = '/adm/wrapper/ext/'.$cfile; + my $escfile = &unescape($cfile); + if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) { + $cfile = '/adm/wrapper'.$escfile; + } else { + $escfile =~ s{^http://}{}; + $cfile = &escape("/adm/wrapper/ext/$escfile"); + } } } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { if ($env{'form.forceedit'}) { @@ -3370,7 +3156,7 @@ sub can_edit_resource { $cfile=$file; } } - if (($cfile ne '') && (!$incourse || $uploaded) && + if (($cfile ne '') && (!$incourse || $uploaded) && (($home ne '') && ($home ne 'no_host'))) { my @ids=¤t_machine_ids(); unless (grep(/^\Q$home\E$/,@ids)) { @@ -3397,9 +3183,9 @@ sub in_course { if ($hideprivileged) { my $skipuser; my %coursehash = &coursedescription($cdom.'_'.$cnum); - my @possdoms = ($cdom); - if ($coursehash{'checkforpriv'}) { - push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); + my @possdoms = ($cdom); + if ($coursehash{'checkforpriv'}) { + push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); } if (&privileged($uname,$udom,\@possdoms)) { $skipuser = 1; @@ -3502,7 +3288,7 @@ sub process_coursefile { $home); } } elsif ($action eq 'uploaddoc') { - open(my $fh,'>',$filepath.'/'.$fname); + open(my $fh,'>'.$filepath.'/'.$fname); print $fh $env{'form.'.$source}; close($fh); if ($parser eq 'parse') { @@ -3560,7 +3346,7 @@ sub store_edited_file { ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); $fpath=$docudom.'/'.$docuname.'/'.$fpath; my $filepath = &build_filepath($fpath); - open(my $fh,'>',$filepath.'/'.$fname); + open(my $fh,'>'.$filepath.'/'.$fname); print $fh $content; close($fh); my $home=&homeserver($docuname,$docudom); @@ -3585,9 +3371,6 @@ sub clean_filename { } # Replace spaces by underscores $fname=~s/\s+/\_/g; -# Transliterate non-ascii text to ascii - my $lang = &Apache::lonlocal::current_language(); - $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang); # Replace all other weird characters by nothing $fname=~s{[^/\w\.\-]}{}g; # Replace all .\d. sequences with _\d. so they no longer look like version @@ -3595,7 +3378,6 @@ sub clean_filename { $fname=~s/\.(\d+)(?=\.)/_$1/g; return $fname; } - # This Function checks if an Image's dimensions exceed either $resizewidth (width) # or $resizeheight (height) - both pixels. If so, the image is scaled to produce an # image with the same aspect ratio as the original, but with dimensions which do @@ -3638,16 +3420,13 @@ sub resizeImage { # 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, scantron or ''. +# 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 # $subdir - directory in userfile to store the file into -# $parser - instruction to parse file for objects ($parser = parse) or -# if context is 'scantron', $parser is hashref of csv column mapping -# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3, -# Section => 4, CODE => 5, FirstQuestion => 9 }). +# $parser - instruction to parse file for objects ($parser = parse) # $allfiles - reference to hash for embedded objects # $codebase - reference to hash for codebase of java objects # $desuname - username for permanent storage of uploaded file @@ -3670,14 +3449,6 @@ sub userfileupload { $fname=&clean_filename($fname); # See if there is anything left unless ($fname) { return 'error: no uploaded file'; } - # If filename now begins with a . prepend unix timestamp _ milliseconds - if ($fname =~ /^\./) { - my ($s,$usec) = &gettimeofday(); - while (length($usec) < 6) { - $usec = '0'.$usec; - } - $fname = $s.'_'.substr($usec,0,3).$fname; - } # 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')) || @@ -3691,12 +3462,12 @@ sub userfileupload { '_'.$env{'user.domain'}.'/pending'; } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { my ($docuname,$docudom); - if ($destudom =~ /^$match_domain$/) { + if ($destudom) { $docudom = $destudom; } else { $docudom = $env{'user.domain'}; } - if ($destuname =~ /^$match_username$/) { + if ($destuname) { $docuname = $destuname; } else { $docuname = $env{'user.name'}; @@ -3726,7 +3497,7 @@ sub userfileupload { mkdir($fullpath,0777); } } - open(my $fh,'>',$fullpath.'/'.$fname); + open(my $fh,'>'.$fullpath.'/'.$fname); print $fh $env{'form.'.$formname}; close($fh); if ($context eq 'existingfile') { @@ -3801,7 +3572,7 @@ sub finishuserfileupload { # Save the file { - if (!open(FH,'>',$filepath.'/'.$file)) { + if (!open(FH,'>'.$filepath.'/'.$file)) { &logthis('Failed to create '.$filepath.'/'.$file); print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); return '/adm/notfound.html'; @@ -3845,7 +3616,7 @@ sub finishuserfileupload { } } } - if (($context ne 'scantron') && ($parser eq 'parse')) { + if ($parser eq 'parse') { if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { my $parse_result = &extract_embedded_items($filepath.'/'.$file, $allfiles,$codebase); @@ -3854,16 +3625,12 @@ sub finishuserfileupload { ' for embedded media: '.$parse_result); } } - } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) { - my $format = $env{'form.scantron_format'}; - &bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format); } if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { my $input = $filepath.'/'.$file; my $output = $filepath.'/'.'tn-'.$file; my $thumbsize = $thumbwidth.'x'.$thumbheight; - my @args = ('convert','-sample',$thumbsize,$input,$output); - system({$args[0]} @args); + system("convert -sample $thumbsize $input $output"); if (-e $filepath.'/'.'tn-'.$file) { $fetchthumb = 1; } @@ -3922,7 +3689,7 @@ sub extract_embedded_items { } if (lc($tagname) eq 'a') { unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) { - &add_filetype($allfiles,$attr->{'href'},'href'); + &add_filetype($allfiles,$attr->{'href'},'href'); } } if (lc($tagname) eq 'script') { @@ -4097,246 +3864,6 @@ sub embedded_dependency { return; } -sub bubblesheet_converter { - my ($cdom,$fullpath,$config,$format) = @_; - if ((&domain($cdom) ne '') && - ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) && - (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) { - my (%csvcols,%csvoptions); - if (ref($config->{'fields'}) eq 'HASH') { - %csvcols = %{$config->{'fields'}}; - } - if (ref($config->{'options'}) eq 'HASH') { - %csvoptions = %{$config->{'options'}}; - } - my %csvbynum = reverse(%csvcols); - my %scantronconf = &get_scantron_config($format,$cdom); - if (keys(%scantronconf)) { - my %bynum = ( - $scantronconf{CODEstart} => 'CODEstart', - $scantronconf{IDstart} => 'IDstart', - $scantronconf{PaperID} => 'PaperID', - $scantronconf{FirstName} => 'FirstName', - $scantronconf{LastName} => 'LastName', - $scantronconf{Qstart} => 'Qstart', - ); - my @ordered; - foreach my $item (sort { $a <=> $b } keys(%bynum)) { - push(@ordered,$bynum{$item}); - } - my %mapstart = ( - CODEstart => 'CODE', - IDstart => 'ID', - PaperID => 'PaperID', - FirstName => 'FirstName', - LastName => 'LastName', - Qstart => 'FirstQuestion', - ); - my %maplength = ( - CODEstart => 'CODElength', - IDstart => 'IDlength', - PaperID => 'PaperIDlength', - FirstName => 'FirstNamelength', - LastName => 'LastNamelength', - ); - if (open(my $fh,'<',$fullpath)) { - my $output; - my %lettdig = &letter_to_digits(); - my %diglett = reverse(%lettdig); - my $numletts = scalar(keys(%lettdig)); - my $num = 0; - while (my $line=<$fh>) { - $num ++; - next if (($num == 1) && ($csvoptions{'hdr'} == 1)); - $line =~ s{[\r\n]+$}{}; - my %found; - my @values = split(/,/,$line); - my ($qstart,$record); - for (my $i=0; $i<@values; $i++) { - if ((($qstart ne '') && ($i > $qstart)) || - ($csvbynum{$i} eq 'FirstQuestion')) { - if ($values[$i] eq '') { - $values[$i] = $scantronconf{'Qoff'}; - } elsif ($scantronconf{'Qon'} eq 'number') { - if ($values[$i] =~ /^[A-Ja-j]$/) { - $values[$i] = $lettdig{uc($values[$i])}; - } - } elsif ($scantronconf{'Qon'} eq 'letter') { - if ($values[$i] =~ /^[0-9]$/) { - $values[$i] = $diglett{$values[$i]}; - } - } else { - if ($values[$i] =~ /^[0-9A-Ja-j]$/) { - my $digit; - if ($values[$i] =~ /^[A-Ja-j]$/) { - $digit = $lettdig{uc($values[$i])}-1; - if ($values[$i] eq 'J') { - $digit += $numletts; - } - } elsif ($values[$i] =~ /^[0-9]$/) { - $digit = $values[$i]-1; - if ($values[$i] eq '0') { - $digit += $numletts; - } - } - my $qval=''; - for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) { - if ($j == $digit) { - $qval .= $scantronconf{'Qon'}; - } else { - $qval .= $scantronconf{'Qoff'}; - } - } - $values[$i] = $qval; - } - } - if (length($values[$i]) > $scantronconf{'Qlength'}) { - $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'}); - } - my $numblank = $scantronconf{'Qlength'} - length($values[$i]); - if ($numblank > 0) { - $values[$i] .= ($scantronconf{'Qoff'} x $numblank); - } - if ($csvbynum{$i} eq 'FirstQuestion') { - $qstart = $i; - $found{$csvbynum{$i}} = $values[$i]; - } else { - $found{'FirstQuestion'} .= $values[$i]; - } - } elsif (exists($csvbynum{$i})) { - if ($csvoptions{'rem'}) { - $values[$i] =~ s/^\s+//; - } - if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) { - while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) { - $values[$i] = '0'.$values[$i]; - } - } - $found{$csvbynum{$i}} = $values[$i]; - } - } - foreach my $item (@ordered) { - my $currlength = 1+length($record); - my $numspaces = $scantronconf{$item} - $currlength; - if ($numspaces > 0) { - $record .= (' ' x $numspaces); - } - if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) { - unless ($item eq 'Qstart') { - if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) { - $found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}}); - } - } - $record .= $found{$mapstart{$item}}; - } - } - $output .= "$record\n"; - } - close($fh); - if ($output) { - if (open(my $fh,'>',$fullpath)) { - print $fh $output; - close($fh); - } - } - } - } - return; - } -} - -sub letter_to_digits { - my %lettdig = ( - A => 1, - B => 2, - C => 3, - D => 4, - E => 5, - F => 6, - G => 7, - H => 8, - I => 9, - J => 0, - ); - return %lettdig; -} - -sub get_scantron_config { - my ($which,$cdom) = @_; - my @lines = &get_scantronformat_file($cdom); - my %config; - #FIXME probably should move to XML it has already gotten a bit much now - foreach my $line (@lines) { - my ($name,$descrip)=split(/:/,$line); - if ($name ne $which ) { next; } - chomp($line); - my @config=split(/:/,$line); - $config{'name'}=$config[0]; - $config{'description'}=$config[1]; - $config{'CODElocation'}=$config[2]; - $config{'CODEstart'}=$config[3]; - $config{'CODElength'}=$config[4]; - $config{'IDstart'}=$config[5]; - $config{'IDlength'}=$config[6]; - $config{'Qstart'}=$config[7]; - $config{'Qlength'}=$config[8]; - $config{'Qoff'}=$config[9]; - $config{'Qon'}=$config[10]; - $config{'PaperID'}=$config[11]; - $config{'PaperIDlength'}=$config[12]; - $config{'FirstName'}=$config[13]; - $config{'FirstNamelength'}=$config[14]; - $config{'LastName'}=$config[15]; - $config{'LastNamelength'}=$config[16]; - $config{'BubblesPerRow'}=$config[17]; - last; - } - return %config; -} - -sub get_scantronformat_file { - my ($cdom) = @_; - if ($cdom eq '') { - $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'}; - } - my %domconfig = &get_dom('configuration',['scantron'],$cdom); - my $gottab = 0; - my @lines; - if (ref($domconfig{'scantron'}) eq 'HASH') { - if ($domconfig{'scantron'}{'scantronformat'} ne '') { - my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'}); - if ($formatfile ne '-1') { - @lines = split("\n",$formatfile,-1); - $gottab = 1; - } - } - } - if (!$gottab) { - my $confname = $cdom.'-domainconfig'; - my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab'; - my $formatfile = &getfile($default); - if ($formatfile ne '-1') { - @lines = split("\n",$formatfile,-1); - $gottab = 1; - } - } - if (!$gottab) { - my @domains = ¤t_machine_domains(); - if (grep(/^\Q$cdom\E$/,@domains)) { - if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) { - @lines = <$fh>; - close($fh); - } - } else { - if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) { - @lines = <$fh>; - close($fh); - } - } - } - return @lines; -} - sub removeuploadedurl { my ($url)=@_; my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); @@ -4487,7 +4014,7 @@ sub flushcourselogs { } } # -# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au) +# Reverse lookup of domain roles (dc, ad, li, sc, au) # my %domrolebuffer = (); foreach my $entry (keys(%domainrolehash)) { @@ -4502,19 +4029,10 @@ sub flushcourselogs { delete $domainrolehash{$entry}; } foreach my $dom (keys(%domrolebuffer)) { - my %servers; - if (defined(&domain($dom,'primary'))) { - my $primary=&domain($dom,'primary'); - my $hostname=&hostname($primary); - $servers{$primary} = $hostname; - } else { - %servers = &get_servers($dom,'library'); - } + my %servers = &get_servers($dom,'library'); foreach my $tryserver (keys(%servers)) { - if (&reply('domroleput:'.$dom.':'. - $domrolebuffer{$dom},$tryserver) eq 'ok') { - last; - } else { + unless (&reply('domroleput:'.$dom.':'. + $domrolebuffer{$dom},$tryserver) eq 'ok') { &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); } } @@ -4634,7 +4152,7 @@ sub userrolelog { {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} =$tend.':'.$tstart; } - if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) { + if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) { my (undef,$rudom,$runame,$rsec)=split(/\//,$area); $domainrolehash {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} @@ -4842,7 +4360,7 @@ sub get_my_roles { } else { my $possdoms = [$domain]; if (ref($roledoms) eq 'ARRAY') { - push(@{$possdoms},@{$roledoms}); + push(@{$possdoms},@{$roledoms}); } if (&privileged($username,$domain,$possdoms,\@privroles)) { if (!$nothide{$username.':'.$domain}) { @@ -4861,195 +4379,6 @@ sub get_my_roles { return %returnhash; } -sub get_all_adhocroles { - my ($dom) = @_; - my @roles_by_num = (); - my %domdefaults = &get_domain_defaults($dom); - my (%description,%access_in_dom,%access_info); - if (ref($domdefaults{'adhocroles'}) eq 'HASH') { - my $count = 0; - my %domcurrent = %{$domdefaults{'adhocroles'}}; - my %ordered; - foreach my $role (sort(keys(%domcurrent))) { - my ($order,$desc,$access_in_dom); - if (ref($domcurrent{$role}) eq 'HASH') { - $order = $domcurrent{$role}{'order'}; - $desc = $domcurrent{$role}{'desc'}; - $access_in_dom{$role} = $domcurrent{$role}{'access'}; - $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}}; - } - if ($order eq '') { - $order = $count; - } - $ordered{$order} = $role; - if ($desc ne '') { - $description{$role} = $desc; - } else { - $description{$role}= $role; - } - $count++; - } - foreach my $item (sort {$a <=> $b } (keys(%ordered))) { - push(@roles_by_num,$ordered{$item}); - } - } - return (\@roles_by_num,\%description,\%access_in_dom,\%access_info); -} - -sub get_my_adhocroles { - my ($cid,$checkreg) = @_; - my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num); - if ($env{'request.course.id'} eq $cid) { - $cdom = $env{'course.'.$cid.'.domain'}; - $cnum = $env{'course.'.$cid.'.num'}; - $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'}; - } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) { - $cdom = $1; - $cnum = $2; - %info = &Apache::lonnet::get('environment',['internal.coursecode'], - $cdom,$cnum); - } - if (($info{'internal.coursecode'} ne '') && ($checkreg)) { - my $user = $env{'user.name'}.':'.$env{'user.domain'}; - my %rosterhash = &get('classlist',[$user],$cdom,$cnum); - if ($rosterhash{$user} ne '') { - my $type = (split(/:/,$rosterhash{$user}))[5]; - return ([],{}) if ($type eq 'auto'); - } - } - if (($cdom ne '') && ($cnum ne '')) { - if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) { - my $then=$env{'user.login.time'}; - my $update=$env{'user.update.time'}; - if (!$update) { - $update = $then; - } - my @liveroles; - foreach my $role ('dh','da') { - if ($env{"user.role.$role./$cdom/"}) { - my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"}); - my $limit = $update; - if ($env{'request.role'} eq "$role./$cdom/") { - $limit = $then; - } - my $activerole = 1; - if ($tstart && $tstart>$limit) { $activerole = 0; } - if ($tend && $tend <$limit) { $activerole = 0; } - if ($activerole) { - push(@liveroles,$role); - } - } - } - if (@liveroles) { - if (&homeserver($cnum,$cdom) ne 'no_host') { - my ($accessref,$accessinfo,%access_in_dom); - ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); - if (ref($roles_by_num) eq 'ARRAY') { - if (@{$roles_by_num}) { - my %settings; - if ($env{'request.course.id'} eq $cid) { - foreach my $envkey (keys(%env)) { - if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) { - $settings{$1} = $env{$envkey}; - } - } - } else { - %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc'); - } - my %setincrs; - if ($settings{'internal.adhocaccess'}) { - map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'}); - } - my @statuses; - if ($env{'environment.inststatus'}) { - @statuses = split(/,/,$env{'environment.inststatus'}); - } - my $user = $env{'user.name'}.':'.$env{'user.domain'}; - if (ref($accessref) eq 'HASH') { - %access_in_dom = %{$accessref}; - } - foreach my $role (@{$roles_by_num}) { - my ($curraccess,@okstatus,@personnel); - if ($setincrs{$role}) { - ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role}); - if ($curraccess eq 'status') { - @okstatus = split(/\&/,$rest); - } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { - @personnel = split(/\&/,$rest); - } - } else { - $curraccess = $access_in_dom{$role}; - if (ref($accessinfo) eq 'HASH') { - if ($curraccess eq 'status') { - if (ref($accessinfo->{$role}) eq 'ARRAY') { - @okstatus = @{$accessinfo->{$role}}; - } - } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { - if (ref($accessinfo->{$role}) eq 'ARRAY') { - @personnel = @{$accessinfo->{$role}}; - } - } - } - } - if ($curraccess eq 'none') { - next; - } elsif ($curraccess eq 'all') { - push(@possroles,$role); - } elsif ($curraccess eq 'dh') { - if (grep(/^dh$/,@liveroles)) { - push(@possroles,$role); - } else { - next; - } - } elsif ($curraccess eq 'da') { - if (grep(/^da$/,@liveroles)) { - push(@possroles,$role); - } else { - next; - } - } elsif ($curraccess eq 'status') { - if (@okstatus) { - if (!@statuses) { - if (grep(/^default$/,@okstatus)) { - push(@possroles,$role); - } - } else { - foreach my $status (@okstatus) { - if (grep(/^\Q$status\E$/,@statuses)) { - push(@possroles,$role); - last; - } - } - } - } - } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { - if (grep(/^\Q$user\E$/,@personnel)) { - if ($curraccess eq 'exc') { - push(@possroles,$role); - } - } elsif ($curraccess eq 'inc') { - push(@possroles,$role); - } - } - } - } - } - } - } - } - } - unless (ref($description) eq 'HASH') { - if (ref($roles_by_num) eq 'ARRAY') { - my %desc; - map { $desc{$_} = $_; } (@{$roles_by_num}); - $description = \%desc; - } else { - $description = {}; - } - } - return (\@possroles,$description); -} - # ----------------------------------------------------- Frontpage Announcements # # @@ -5063,7 +4392,7 @@ sub postannounce { sub getannounce { - if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) { + if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { my $announcement=''; while (my $line = <$fh>) { $announcement .= $line; } close($fh); @@ -5139,16 +4468,16 @@ sub courseiddump { if (($domfilter eq '') || (&host_domain($tryserver) eq $domfilter)) { my $rep; - if (grep { $_ eq $tryserver } ¤t_machine_ids()) { - $rep = &LONCAPA::Lond::dump_course_id_handler( - join(":", (&host_domain($tryserver), $sincefilter, - &escape($descfilter), &escape($instcodefilter), + if (grep { $_ eq $tryserver } current_machine_ids()) { + $rep = LONCAPA::Lond::dump_course_id_handler( + join(":", (&host_domain($tryserver), $sincefilter, + &escape($descfilter), &escape($instcodefilter), &escape($ownerfilter), &escape($coursefilter), - &escape($typefilter), &escape($regexp_ok), - $as_hash, &escape($selfenrollonly), - &escape($catfilter), $showhidden, $caller, - &escape($cloner), &escape($cc_clone), $cloneonly, - &escape($createdbefore), &escape($createdafter), + &escape($typefilter), &escape($regexp_ok), + $as_hash, &escape($selfenrollonly), + &escape($catfilter), $showhidden, $caller, + &escape($cloner), &escape($cc_clone), $cloneonly, + &escape($createdbefore), &escape($createdafter), &escape($creationcontext),$domcloner,$hasuniquecode, $reqcrsdom,&escape($reqinstcode)))); } else { @@ -5164,7 +4493,7 @@ sub courseiddump { &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); } - + my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -5290,21 +4619,6 @@ sub get_domain_roles { return %personnel; } -sub get_active_domroles { - my ($dom,$roles) = @_; - return () unless (ref($roles) eq 'ARRAY'); - my $now = time; - my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now); - my %domroles; - foreach my $server (keys(%dompersonnel)) { - foreach my $user (sort(keys(%{$dompersonnel{$server}}))) { - my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user); - $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user}; - } - } - return %domroles; -} - # ----------------------------------------------------------- Interval timing { @@ -5359,12 +4673,7 @@ sub set_first_access { } $cachedkey=''; my $firstaccess=&get_first_access($type,$symb,$map); - if ($firstaccess) { - &logthis("First access time already set ($firstaccess) when attempting ". - "to set new value (type: $type, extent: $res) for $uname:$udom ". - "in $courseid"); - return 'already_set'; - } else { + if (!$firstaccess) { my $start = time; my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start}, $udom,$uname); @@ -5377,12 +4686,6 @@ sub set_first_access { 'course.'.$courseid.'.timerinterval.'.$res => $interval, } ); - if (($cachedtime) && (abs($start-$cachedtime) < 5)) { - $cachedtimes{"$courseid\0$res"} = $start; - } - } elsif ($putres ne 'refused') { - &logthis("Result: $putres when attempting to set first access time ". - "(type: $type, extent: $res) for $uname:$udom in $courseid"); } return $putres; } @@ -5390,91 +4693,6 @@ sub set_first_access { } } -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 { @@ -6068,7 +5286,7 @@ sub privileged { my $now = time; my $roles; if (ref($possroles) eq 'ARRAY') { - $roles = $possroles; + $roles = $possroles; } else { $roles = ['dc','su']; } @@ -6095,7 +5313,7 @@ sub privileged { for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) { my ($trole, $tend, $tstart) = split(/_/, $role); if (grep(/^\Q$trole\E$/,@{$roles})) { - return 1 unless ($tend && $tend < $now) + return 1 unless ($tend && $tend < $now) or ($tstart && $tstart > $now); } } @@ -6133,7 +5351,7 @@ sub privileged_by_domain { my ($trole,$uname,$udom,$rest) = split(/:/,$item,4); my ($end,$start) = split(/:/,$dompersonnel{$server}{$item}); next if ($end && $end < $now); - $privileged{$dom}{$trole}{$uname.':'.$udom} = + $privileged{$dom}{$trole}{$uname.':'.$udom} = $dompersonnel{$server}{$item}; } } @@ -6254,10 +5472,9 @@ sub rolesinit { } } - @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, - \%allroles, \%allgroups); + @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles, + \%allroles, \%allgroups); $env{'user.adv'} = $userroles{'user.adv'}; - $env{'user.rar'} = $userroles{'user.rar'}; return (\%userroles,\%firstaccenv,\%timerintenv); } @@ -6293,10 +5510,6 @@ sub custom_roleprivs { $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; } if (($trest ne '') && (defined($coursepriv))) { - if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) { - my $rolename = $1; - $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv); - } $$allroles{'cm.'.$area}.=':'.$coursepriv; $$allroles{$spec.'.'.$area}.=':'.$coursepriv; } @@ -6305,48 +5518,6 @@ sub custom_roleprivs { } } -sub course_adhocrole_privs { - my ($rolename,$cdom,$cnum,$coursepriv) = @_; - my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum); - if ($overrides{"internal.adhocpriv.$rolename"}) { - my (%currprivs,%storeprivs); - foreach my $item (split(/:/,$coursepriv)) { - my ($priv,$restrict) = split(/\&/,$item); - $currprivs{$priv} = $restrict; - } - my (%possadd,%possremove,%full); - foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) { - my ($priv,$restrict)=split(/\&/,$item); - $full{$priv} = $restrict; - } - foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) { - next if ($item eq ''); - my ($rule,$rest) = split(/=/,$item); - next unless (($rule eq 'off') || ($rule eq 'on')); - foreach my $priv (split(/:/,$rest)) { - if ($priv ne '') { - if ($rule eq 'off') { - $possremove{$priv} = 1; - } else { - $possadd{$priv} = 1; - } - } - } - } - foreach my $priv (sort(keys(%full))) { - if (exists($currprivs{$priv})) { - unless (exists($possremove{$priv})) { - $storeprivs{$priv} = $currprivs{$priv}; - } - } elsif (exists($possadd{$priv})) { - $storeprivs{$priv} = $full{$priv}; - } - } - $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs))); - } - return $coursepriv; -} - sub group_roleprivs { my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; my $access = 1; @@ -6381,7 +5552,6 @@ sub set_userprivs { my ($userroles,$allroles,$allgroups,$groups_roles) = @_; my $author=0; my $adv=0; - my $rar=0; my %grouproles = (); if (keys(%{$allgroups}) > 0) { my @groupkeys; @@ -6429,7 +5599,6 @@ sub set_userprivs { $thesepriv{$privilege}.=$restrictions; } if ($thesepriv{'adv'} eq 'F') { $adv=1; } - if ($thesepriv{'rar'} eq 'F') { $rar=1; } } } my $thesestr=''; @@ -6438,7 +5607,7 @@ sub set_userprivs { } $userroles->{'user.priv.'.$role} = $thesestr; } - return ($author,$adv,$rar); + return ($author,$adv); } sub role_status { @@ -6483,10 +5652,9 @@ sub role_status { push(@rolecodes,$$role); &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); } - my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, - \%groups_roles); + my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); &appenv(\%userroles,\@rolecodes); - &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); } } $$tstatus = 'is'; @@ -6562,56 +5730,39 @@ sub delete_env_groupprivs { } sub check_adhoc_privs { - my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_; + my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_; my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; - if ($sec) { - $cckey .= '/'.$sec; - } my $setprivs; if ($env{$cckey}) { my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { - &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); + &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); $setprivs = 1; } } else { - &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); + &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); $setprivs = 1; } return $setprivs; } sub set_adhoc_privileges { -# role can be cc, ca, or cr//-domainconfig/role - my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_; +# role can be cc or ca + my ($dcdom,$pickedcourse,$role,$caller) = @_; my $area = '/'.$dcdom.'/'.$pickedcourse; - if ($sec ne '') { - $area .= '/'.$sec; - } my $spec = $role.'.'.$area; my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, $env{'user.name'},1); - my %rolehash = (); - if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) { - my $rolename = $1; - &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area); - my %domdef = &get_domain_defaults($dcdom); - if (ref($domdef{'adhocroles'}) eq 'HASH') { - if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') { - &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},}); - } - } - } else { - &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); - } - my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); + my %ccrole = (); + &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); + my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); &appenv(\%userroles,[$role,'cm']); - &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); + &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' => $sec, + 'request.course.sec' => '' } ); my $tadv=0; @@ -6671,14 +5822,15 @@ sub unserialize { return {} if $rep =~ /^error/; my %returnhash=(); - foreach my $item (split(/\&/,$rep)) { - my ($key, $value) = split(/=/, $item, 2); - $key = unescape($key) unless $escapedkeys; - next if $key =~ /^error: 2 /; - $returnhash{$key} = &thaw_unescape($value); - } + foreach my $item (split(/\&/,$rep)) { + my ($key, $value) = split(/=/, $item, 2); + $key = unescape($key) unless $escapedkeys; + next if $key =~ /^error: 2 /; + $returnhash{$key} = &thaw_unescape($value); + } + #return %returnhash; return \%returnhash; -} +} # see Lond::dump_with_regexp # if $escapedkeys hash keys won't get unescaped. @@ -6693,11 +5845,11 @@ sub dump { } else { $regexp='.'; } - if (grep { $_ eq $uhome } ¤t_machine_ids()) { + if (grep { $_ eq $uhome } current_machine_ids()) { # user is hosted on this machine - my $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain, + my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); - return %{&unserialize($reply, $escapedkeys)}; + return %{unserialize($reply, $escapedkeys)}; } my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); my @pairs=split(/\&/,$rep); @@ -6705,7 +5857,8 @@ sub dump { if (!($rep =~ /^error/ )) { foreach my $item (@pairs) { my ($key,$value)=split(/=/,$item,2); - $key = &unescape($key) unless ($escapedkeys); + $key = unescape($key) unless $escapedkeys; + #$key = &unescape($key); next if ($key =~ /^error: 2 /); $returnhash{$key}=&thaw_unescape($value); } @@ -6749,7 +5902,7 @@ sub currentdump { my $rep; if (grep { $_ eq $uhome } current_machine_ids()) { - $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, + $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, $courseid))); } else { $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome); @@ -6993,11 +6146,9 @@ sub tmpget { if (!defined($server)) { $server = $perlvar{'lonHostID'}; } my $rep=&reply("tmpget:$token",$server); my %returnhash; - if ($rep =~ /^(con_lost|error|no_such_host)/i) { - return %returnhash; - } foreach my $item (split(/\&/,$rep)) { my ($key,$value)=split(/=/,$item); + next if ($key =~ /^error: 2 /); $returnhash{&unescape($key)}=&thaw_unescape($value); } return %returnhash; @@ -7010,13 +6161,13 @@ sub tmpdel { return &reply("tmpdel:$token",$server); } -# ------------------------------------------------------------ get_timebased_id +# ------------------------------------------------------------ get_timebased_id sub get_timebased_id { my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries, $maxtries) = @_; my ($newid,$error,$dellock); - unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) { + unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) { return ('','ok','invalid call to get suffix'); } @@ -7030,7 +6181,7 @@ sub get_timebased_id { if (!$maxtries) { $maxtries = 10; } - + if (($cdom eq '') || ($cnum eq '')) { if ($env{'request.course.id'}) { $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; @@ -7185,7 +6336,7 @@ sub get_portfolio_access { if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') { if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) { $allowed = 1; - last; + last; } } } @@ -7413,7 +6564,7 @@ sub usertools_access { my ($toolstatus,$inststatus,$envkey); if ($context eq 'requestauthor') { - $envkey = $context; + $envkey = $context; } else { $envkey = $context.'.'.$tool; } @@ -7913,7 +7064,7 @@ sub allowed { && &is_portfolio_url($uri)) { $thisallowed = &portfolio_access($uri,$clientip); } - + # Full access at system, domain or course-wide level? Exit. if ($thisallowed=~/F/) { return 'F'; @@ -8180,7 +7331,7 @@ sub constructaccess { my ($ownername,$ownerdomain,$ownerhome); ($ownerdomain,$ownername) = - ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)(?:/|$)}); + ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)/}); # The URL does not really point to any authorspace, forget it unless (($ownername) && ($ownerdomain)) { return ''; } @@ -8243,14 +7394,14 @@ sub constructaccess { # # User for whom data are being temporarily cached. my $cacheduser=''; -# Cached blockers for this user (a hash of blocking items). +# Cached blockers for this user (a hash of blocking items). my %cachedblockers=(); # When the data were last cached. my $cachedlast=''; sub load_all_blockers { my ($uname,$udom,$blocks)=@_; - if (($uname ne '') && ($udom ne '')) { + if (($uname ne '') && ($udom ne '')) { if (($cacheduser eq $uname.':'.$udom) && (abs($cachedlast-time)<5)) { return; @@ -8292,7 +7443,7 @@ sub get_commblock_resources { } else { %commblocks = &get_comm_blocks(); } - return %blockers unless (keys(%commblocks) > 0); + return %blockers unless (keys(%commblocks) > 0); my $navmap = Apache::lonnavmaps::navmap->new(); return %blockers unless (ref($navmap)); my $now = time; @@ -8304,7 +7455,7 @@ sub get_commblock_resources { if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { - $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; + $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; } } if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { @@ -8329,8 +7480,8 @@ sub get_commblock_resources { if ($item =~ /___\d+___/) { $type = 'resource'; @interval=&EXT("resource.0.interval",$item); - if (ref($navmap)) { - my $res = $navmap->getBySymb($item); + if (ref($navmap)) { + my $res = $navmap->getBySymb($item); push(@to_test,$res); } } else { @@ -8353,7 +7504,8 @@ sub get_commblock_resources { } } } - if ($interval[0] =~ /^\d+$/) { + if ($interval[0] =~ /^\d+/) { + my ($timelimit) = split(/_/,$interval[0]); my $first_access; if ($type eq 'resource') { $first_access=&get_first_access($interval[1],$item); @@ -8363,7 +7515,7 @@ sub get_commblock_resources { $first_access=&get_first_access($interval[1]); } if ($first_access) { - my $timesup = $first_access+$interval[0]; + my $timesup = $first_access+$timelimit; if ($timesup > $now) { my $activeblock; foreach my $res (@to_test) { @@ -8409,7 +7561,7 @@ sub has_comm_blocking { } if ($symb) { @symbs = ($symb); - } elsif (keys(%possibles)) { + } elsif (keys(%possibles)) { @symbs = keys(%possibles); } my $noblock; @@ -8447,7 +7599,7 @@ sub has_comm_blocking { } } -# -------------------------------- Deversion and split uri into path an filename +# -------------------------------- Deversion and split uri into path an filename # # Removes the version from a URI and @@ -8518,7 +7670,7 @@ sub get_symb_from_alias { sub definerole { if (allowed('mcr','/')) { - my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_; + my ($rolename,$sysrole,$domrole,$courole)=@_; foreach my $role (split(':',$sysrole)) { my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } @@ -8546,19 +7698,11 @@ sub definerole { } } } - my $uhome; - if (($uname ne '') && ($udom ne '')) { - $uhome = &homeserver($uname,$udom); - return $uhome if ($uhome eq 'no_host'); - } else { - $uname = $env{'user.name'}; - $udom = $env{'user.domain'}; - $uhome = $env{'user.home'}; - } my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". - "$udom:$uname:rolesdef_$rolename=". + "$env{'user.domain'}:$env{'user.name'}:". + "rolesdef_$rolename=". escape($sysrole.'_'.$domrole.'_'.$courole); - return reply($command,$uhome); + return reply($command,$env{'user.home'}); } else { return 'refused'; } @@ -8573,9 +7717,9 @@ sub metadata_query { my @server_list = (defined($server_array) ? @$server_array : keys(%libserv) ); for my $server (@server_list) { - my $domains = ''; + my $domains = ''; if (ref($domains_hash) eq 'HASH') { - $domains = $domains_hash->{$server}; + $domains = $domains_hash->{$server}; } unless ($custom or $customshow) { my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server); @@ -8640,12 +7784,10 @@ sub update_allusers_table { sub fetch_enrollment_query { my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; - my ($homeserver,$sleep,$loopmax); + my $homeserver; my $maxtries = 1; if ($context eq 'automated') { $homeserver = $perlvar{'lonHostID'}; - $sleep = 2; - $loopmax = 100; $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout } else { $homeserver = &homeserver($cnum,$dom); @@ -8663,17 +7805,17 @@ sub fetch_enrollment_query { &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); return 'error: '.$queryid; } - my $reply = &get_query_reply($queryid,$sleep,$loopmax); + my $reply = &get_query_reply($queryid); my $tries = 1; while (($reply=~/^timeout/) && ($tries < $maxtries)) { - $reply = &get_query_reply($queryid,$sleep,$loopmax); + $reply = &get_query_reply($queryid); $tries ++; } if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); } else { my @responses = split(/:/,$reply); - if (grep { $_ eq $homeserver } ¤t_machine_ids()) { + if ($homeserver eq $perlvar{'lonHostID'}) { foreach my $line (@responses) { my ($key,$value) = split(/=/,$line,2); $$replyref{$key} = $value; @@ -8691,7 +7833,7 @@ sub fetch_enrollment_query { if ($xml_classlist =~ /^error/) { &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); } else { - if ( open(FILE,">",$destname) ) { + if ( open(FILE,">$destname") ) { print FILE &unescape($xml_classlist); close(FILE); } else { @@ -8708,19 +7850,13 @@ sub fetch_enrollment_query { } sub get_query_reply { - my ($queryid,$sleep,$loopmax) = @_; - if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) { - $sleep = 0.2; - } - if (($loopmax eq '') || ($loopmax =~ /\D/)) { - $loopmax = 100; - } + my $queryid=shift; my $replyfile=LONCAPA::tempdir().$queryid; my $reply=''; - for (1..$loopmax) { - sleep($sleep); + for (1..100) { + sleep(0.2); if (-e $replyfile.'.end') { - if (open(my $fh,"<",$replyfile)) { + if (open(my $fh,$replyfile)) { $reply = join('',<$fh>); close($fh); } else { return 'error: reply_file_error'; } @@ -9112,33 +8248,6 @@ sub auto_validate_class_sec { return $response; } -sub auto_validate_instclasses { - my ($cdom,$cnum,$owners,$classesref) = @_; - my ($homeserver,%validations); - $homeserver = &homeserver($cnum,$cdom); - unless ($homeserver eq 'no_host') { - my $ownerlist; - if (ref($owners) eq 'ARRAY') { - $ownerlist = join(',',@{$owners}); - } else { - $ownerlist = $owners; - } - if (ref($classesref) eq 'HASH') { - my $classes = &freeze_escape($classesref); - my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist). - ':'.$cdom.':'.$classes,$homeserver); - unless ($response =~ /(con_lost|error|no_such_host|refused)/) { - my @items = split(/&/,$response); - foreach my $item (@items) { - my ($key,$value) = split('=',$item); - $validations{&unescape($key)} = &thaw_unescape($value); - } - } - } - } - return %validations; -} - sub auto_crsreq_update { my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, $code,$accessstart,$accessend,$inbound) = @_; @@ -9155,7 +8264,8 @@ sub auto_crsreq_update { ':'.&escape($action).':'.&escape($ownername).':'. &escape($ownerdomain).':'.&escape($fullname).':'. &escape($title).':'.&escape($code).':'. - &escape($accessstart).':'.&escape($accessend).':'.$info,$homeserver); + &escape($accessstart).':'.&escape($accessend).':'.$info, + $homeserver); unless ($response =~ /(con_lost|error|no_such_host|refused)/) { my @items = split(/&/,$response); foreach my $item (@items) { @@ -9167,33 +8277,6 @@ sub auto_crsreq_update { return \%crsreqresponse; } -sub auto_export_grades { - my ($cdom,$cnum,$inforef,$gradesref) = @_; - my ($homeserver,%exportresponse); - if ($cdom =~ /^$match_domain$/) { - $homeserver = &domain($cdom,'primary'); - } - unless (($homeserver eq 'no_host') || ($homeserver eq '')) { - my $info; - if (ref($inforef) eq 'HASH') { - $info = &freeze_escape($inforef); - } - if (ref($gradesref) eq 'HASH') { - my $grades = &freeze_escape($gradesref); - my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'. - $info.':'.$grades,$homeserver); - unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) { - my @items = split(/&/,$response); - foreach my $item (@items) { - my ($key,$value) = split('=',$item); - $exportresponse{&unescape($key)} = &thaw_unescape($value); - } - } - } - } - return \%exportresponse; -} - sub check_instcode_cloning { my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { @@ -9536,7 +8619,7 @@ sub assignrole { } } } elsif ($context eq 'requestauthor') { - if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && ($url eq '/'.$udom.'/') && ($role eq 'au')) { if ($env{'environment.requestauthor'} eq 'automatic') { $refused = ''; @@ -9544,13 +8627,13 @@ sub assignrole { my %domdefaults = &get_domain_defaults($udom); if (ref($domdefaults{'requestauthor'}) eq 'HASH') { my $checkbystatus; - if ($env{'user.adv'}) { + if ($env{'user.adv'}) { my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; if ($disposition eq 'automatic') { $refused = ''; } elsif ($disposition eq '') { $checkbystatus = 1; - } + } } else { $checkbystatus = 1; } @@ -9632,13 +8715,12 @@ sub assignrole { &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, $selfenroll,$context); } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || - ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') || - ($role eq 'da')) { + ($role eq 'au') || ($role eq 'dc')) { &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, $context); } elsif (($role eq 'ca') || ($role eq 'aa')) { &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, - $context); + $context); } if ($role eq 'cc') { &autoupdate_coowners($url,$end,$start,$uname,$udom); @@ -9828,7 +8910,7 @@ sub modifyuser { 'current user id "'.$uidhash{$uname}.'".'; } } else { - &idput($udom,($uname => $uid)); + &idput($udom,{$uname => $uid},$uhome,'ids'); } } # -------------------------------------------------------------- Add names, etc @@ -9938,7 +9020,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, - $selfenroll,$context,$inststatus,$credits,$instsec)=@_; + $selfenroll,$context,$inststatus,$credits)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -9953,14 +9035,14 @@ sub modifystudent { # student's environment $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, - $gene,$usec,$end,$start,$type,$locktype, - $cid,$selfenroll,$context,$credits,$instsec); + $gene,$usec,$end,$start,$type,$locktype, + $cid,$selfenroll,$context,$credits); return $reply; } sub modify_student_enrollment { my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, - $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_; + $locktype,$cid,$selfenroll,$context,$credits) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -10007,7 +9089,7 @@ sub modify_student_enrollment { my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); my $reply=cput('classlist', {$user => - join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) }, + join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) }, $cdom,$cnum); if (($reply eq 'ok') || ($reply eq 'delayed')) { &devalidate_getsection_cache($udom,$uname,$cid); @@ -10230,25 +9312,13 @@ sub generate_coursenum { sub is_course { my ($cdom, $cnum) = scalar(@_) == 1 ? ($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; - return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)); - my $uhome=&homeserver($cnum,$cdom); - my $iscourse; - if (grep { $_ eq $uhome } current_machine_ids()) { - $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum); - } else { - my $hashid = $cdom.':'.$cnum; - ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid); - unless (defined($cached)) { - my %courses = &courseiddump($cdom, '.', 1, '.', '.', - $cnum,undef,undef,'.'); - $iscourse = 0; - if (exists($courses{$cdom.'_'.$cnum})) { - $iscourse = 1; - } - &do_cache_new('iscourse',$hashid,$iscourse,3600); - } - } - return unless($iscourse); + + return unless $cdom and $cnum; + + my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef, + '.'); + + return unless(exists($courses{$cdom.'_'.$cnum})); return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; } @@ -10384,7 +9454,7 @@ sub save_selected_files { my ($user, $path, @files) = @_; my $filename = $user."savedfiles"; my @other_files = &files_not_in_path($user, $path); - open (OUT,'>',LONCAPA::tempdir().$filename); + open (OUT, '>'.$tmpdir.$filename); foreach my $file (@files) { print (OUT $env{'form.currentpath'}.$file."\n"); } @@ -10398,7 +9468,7 @@ sub save_selected_files { sub clear_selected_files { my ($user) = @_; my $filename = $user."savedfiles"; - open (OUT,'>',LONCAPA::tempdir().$filename); + open (OUT, '>'.LONCAPA::tempdir().$filename); print (OUT undef); close (OUT); return ("ok"); @@ -10408,7 +9478,7 @@ sub files_in_path { my ($user, $path) = @_; my $filename = $user."savedfiles"; my %return_files; - open (IN,'<',LONCAPA::tempdir().$filename); + open (IN, '<'.LONCAPA::tempdir().$filename); while (my $line_in = ) { chomp ($line_in); my @paths_and_file = split (m!/!, $line_in); @@ -10430,7 +9500,7 @@ sub files_not_in_path { my $filename = $user."savedfiles"; my @return_files; my $path_part; - open(IN, '<',LONCAPA::tempdir().$filename); + open(IN, '<'.LONCAPA::.$filename); while (my $line = ) { #ok, I know it's clunky, but I want it to work my @paths_and_file = split(m|/|, $line); @@ -10447,6 +9517,90 @@ sub files_not_in_path { return (@return_files); } +#------------------------------Submitted/Handedback Portfolio Files Versioning + +sub portfiles_versioning { + my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_; + my $portfolio_root = '/userfiles/portfolio'; + return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY')); + foreach my $file (@{$portfiles}) { + &unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file); + my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/); + my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file); + my $getpropath = 1; + my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain, + $stu_name,$getpropath); + my $version = &get_next_version($answer_name,$answer_ext,$dir_list); + my $new_answer = + &version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version); + if ($new_answer ne 'problem getting file') { + push(@{$versioned_portfiles}, $directory.$new_answer); + &mark_as_readonly($domain,$stu_name,[$directory.$new_answer], + [$symb,$env{'request.course.id'},'graded']); + } + } +} + +sub get_next_version { + my ($answer_name, $answer_ext, $dir_list) = @_; + my $version; + if (ref($dir_list) eq 'ARRAY') { + foreach my $row (@{$dir_list}) { + my ($file) = split(/\&/,$row,2); + my ($file_name,$file_version,$file_ext) = + &file_name_version_ext($file); + if (($file_name eq $answer_name) && + ($file_ext eq $answer_ext)) { + # gets here if filename and extension match, + # regardless of version + if ($file_version ne '') { + # a versioned file is found so save it for later + if ($file_version > $version) { + $version = $file_version; + } + } + } + } + } + $version ++; + return($version); +} + +sub version_selected_portfile { + my ($domain,$stu_name,$directory,$file_name,$version) = @_; + my ($answer_name,$answer_ver,$answer_ext) = + &file_name_version_ext($file_name); + my $new_answer; + $env{'form.copy'} = + &getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name"); + if($env{'form.copy'} eq '-1') { + $new_answer = 'problem getting file'; + } else { + $new_answer = $answer_name.'.'.$version.'.'.$answer_ext; + my $copy_result = + &finishuserfileupload($stu_name,$domain,'copy', + '/portfolio'.$directory.$new_answer); + } + undef($env{'form.copy'}); + return ($new_answer); +} + +sub file_name_version_ext { + my ($file)=@_; + my @file_parts = split(/\./, $file); + my ($name,$version,$ext); + if (@file_parts > 1) { + $ext=pop(@file_parts); + if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) { + $version=pop(@file_parts); + } + $name=join('.',@file_parts); + } else { + $name=join('.',@file_parts); + } + return($name,$version,$ext); +} + #----------------------------------------------Get portfolio file permissions sub get_portfile_permissions { @@ -10591,49 +9745,132 @@ sub modify_access_controls { } sub make_public_indefinitely { - my ($requrl) = @_; + my (@requrl) = @_; + return &automated_portfile_access('public',\@requrl); +} + +sub automated_portfile_access { + my ($accesstype,$addsref,$delsref,$info) = @_; + unless (($accesstype eq 'public') || ($accesstype eq 'ip')) { + return 'invalid'; + } + my %urls; + if (ref($addsref) eq 'ARRAY') { + foreach my $requrl (@{$addsref}) { + if (&is_portfolio_url($requrl)) { + unless (exists($urls{$requrl})) { + $urls{$requrl} = 'add'; + } + } + } + } + if (ref($delsref) eq 'ARRAY') { + foreach my $requrl (@{$delsref}) { + if (&is_portfolio_url($requrl)) { + unless (exists($urls{$requrl})) { + $urls{$requrl} = 'delete'; + } + } + } + } + unless (keys(%urls)) { + return 'invalid'; + } + my $ip; + if ($accesstype eq 'ip') { + if (ref($info) eq 'HASH') { + if ($info->{'ip'} ne '') { + $ip = $info->{'ip'}; + } + } + if ($ip eq '') { + return 'invalid'; + } + } + my $errors; my $now = time; - my $action = 'activate'; - my $aclnum = 0; - if (&is_portfolio_url($requrl)) { + my %current_perms; + foreach my $requrl (sort(keys(%urls))) { + my $action; + if ($urls{$requrl} eq 'add') { + $action = 'activate'; + } else { + $action = 'none'; + } + my $aclnum = 0; 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, + unless (exists($current_perms{$unum.':'.$udom})) { + $current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum); + } + my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom}, $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 { + if ($scope eq $accesstype) { + if (($start <= $now) && ($end == 0)) { + if ($accesstype eq 'ip') { + if (ref($access_controls{$file_name}{$key}) eq 'HASH') { + if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') { + if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) { + if ($urls{$requrl} eq 'add') { + $action = 'none'; + last; + } else { + $action = 'delete'; + $aclnum = $num; + last; + } + } + } + } + } elsif ($accesstype eq 'public') { + if ($urls{$requrl} eq 'add') { + $action = 'none'; + last; + } else { + $action = 'delete'; + $aclnum = $num; + last; + } + } + } elsif ($accesstype eq 'public') { $action = 'update'; $aclnum = $num; + last; } - last; } } if ($action eq 'none') { - return 'ok'; + next; } else { my %changes; my $newend = 0; my $newstart = $now; - my $newkey = $aclnum.':public_'.$newend.'_'.$newstart; + my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart; $changes{$action}{$newkey} = { - type => 'public', + type => $accesstype, time => { start => $newstart, end => $newend, }, }; + if ($accesstype eq 'ip') { + $changes{$action}{$newkey}{'ip'} = [$ip]; + } my ($outcome,$deloutcome,$new_values,$translation) = &modify_access_controls($file_name,\%changes,$udom,$unum); - return $outcome; + unless ($outcome eq 'ok') { + $errors .= $outcome.' '; + } } + } + if ($errors) { + $errors =~ s/\s$//; + return $errors; } else { - return 'invalid'; + return 'ok'; } } @@ -10838,23 +10075,7 @@ sub dirlist { foreach my $user (sort(keys(%allusers))) { push(@alluserslist,$user.'&user'); } - if (!%listerror) { - # no errors - return (\@alluserslist); - } elsif (scalar(keys(%servers)) == 1) { - # one library server, one error - my ($key) = keys(%listerror); - return (\@alluserslist, $listerror{$key}); - } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) { - # con_lost indicates that we might miss data from at least one - # library server - return (\@alluserslist, 'con_lost'); - } else { - # multiple library servers and no con_lost -> data should be - # complete. - return (\@alluserslist); - } - + return (\@alluserslist); } else { return ([],'missing username'); } @@ -11116,6 +10337,25 @@ sub resdata { return undef; } +sub get_domain_ltitools { + my ($cdom) = @_; + my %ltitools; + my ($result,$cached)=&is_cached_new('ltitools',$cdom); + if (defined($cached)) { + if (ref($result) eq 'HASH') { + %ltitools = %{$result}; + } + } else { + my %domconfig = &get_dom('configuration',['ltitools'],$cdom); + if (ref($domconfig{'ltitools'}) eq 'HASH') { + %ltitools = %{$domconfig{'ltitools'}}; + } + my $cachetime = 24*60*60; + &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); + } + return %ltitools; +} + sub get_numsuppfiles { my ($cnum,$cdom,$ignorecache)=@_; my $hashid=$cnum.':'.$cdom; @@ -11128,7 +10368,7 @@ sub get_numsuppfiles { unless ($chome eq 'no_host') { ($suppcount,my $errors) = (0,0); my $suppmap = 'supplemental.sequence'; - ($suppcount,$errors) = + ($suppcount,$errors) = &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors); } &do_cache_new('suppcount',$hashid,$suppcount,600); @@ -11323,7 +10563,7 @@ sub EXT { $courseid = $cid; } if (($symbparm && $courseid) && - (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) { + (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) { #print '
'.$space.' - '.$qualifier.' - '.$spacequalifierrest; @@ -11564,14 +10804,13 @@ sub add_prefix_and_part { my %metaentry; my %importedpartids; -my %importedrespids; sub metadata { my ($uri,$what,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); # if it is a non metadata possible uri return quickly if (($uri eq '') || (($uri =~ m|^/*adm/|) && - ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || + ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|exttools?)$})) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } @@ -11592,11 +10831,9 @@ sub metadata { } { # Imported parts would go here - my @origfiletagids=(); + my %importedids=(); + my @origfileimportpartids=(); my $importedparts=0; - -# Imported responseids would go here - my $importedresponses=0; # # Is this a recursive call for a library? # @@ -11691,37 +10928,8 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - - my $importid=$token->[2]->{'id'}; + my $importmode=$token->[2]->{'importmode'}; -# -# Check metadata for imported file to -# see if it contained response items -# - my %currmetaentry = %metaentry; - my $libresponseorder = &metadata($location,'responseorder'); - my $origfile; - if ($libresponseorder ne '') { - if ($#origfiletagids<0) { - undef(%importedrespids); - undef(%importedpartids); - } - @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder); - if (@{$importedrespids{$importid}} > 0) { - $importedresponses = 1; -# We need to get the original file and the imported file to get the response order correct -# Load and inspect original file - if ($#origfiletagids<0) { - my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); - $origfile=&getfile($origfilelocation); - @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); - } - } - } -# Do not overwrite contents of %metaentry hash for resource itself with -# hash populated for imported library file - %metaentry = %currmetaentry; - undef(%currmetaentry); if ($importmode eq 'problem') { # Import as problem/response $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); @@ -11730,15 +10938,12 @@ sub metadata { $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 if we didn't do that already - if ($#origfiletagids<0) { - undef(%importedrespids); - undef(%importedpartids); - if ($origfile eq '') { - my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); - $origfile=&getfile($origfilelocation); - @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); - } +# Load and inspect original file + if ($#origfileimportpartids<0) { + undef(%importedpartids); + my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); + my $origfile=&getfile($origfilelocation); + @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); } # Load and inspect imported file @@ -11852,48 +11057,20 @@ sub metadata { grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); $metaentry{':packages'} = join(',',@uniq_packages); - if (($importedresponses) || ($importedparts)) { - if ($importedparts) { + if ($importedparts) { # We had imported parts and need to rebuild partorder - $metaentry{':partorder'}=''; - $metathesekeys{'partorder'}=1; - } - if ($importedresponses) { -# We had imported responses and need to rebuild responseorder - $metaentry{':responseorder'}=''; - $metathesekeys{'responseorder'}=1; - } - for (my $index=0;$index<$#origfiletagids;$index+=2) { - my $origid = $origfiletagids[$index+1]; - if ($origfiletagids[$index] eq 'part') { -# Original part, part of the problem - if ($importedparts) { - $metaentry{':partorder'}.=','.$origid; - } - } elsif ($origfiletagids[$index] eq 'import') { - if ($importedparts) { -# We have imported parts at this position - $metaentry{':partorder'}.=','.$importedpartids{$origid}; - } - if ($importedresponses) { -# We have imported responses at this position - if (ref($importedrespids{$origid}) eq 'ARRAY') { - $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}}); - } - } - } else { -# Original response item, part of the problem - if ($importedresponses) { - $metaentry{':responseorder'}.=','.$origid; - } - } - } - if ($importedparts) { - $metaentry{':partorder'}=~s/^\,//; - } - if ($importedresponses) { - $metaentry{':responseorder'}=~s/^\,//; - } + $metaentry{':partorder'}=''; + $metathesekeys{'partorder'}=1; + for (my $index=0;$index<$#origfileimportpartids;$index+=2) { + if ($origfileimportpartids[$index] eq 'part') { +# original part, part of the problem + $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; + } else { +# we have imported parts at this position + $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; + } + } + $metaentry{':partorder'}=~s/^\,//; } $metaentry{':keys'} = join(',',keys(%metathesekeys)); @@ -12174,7 +11351,7 @@ sub symbverify { $ids=$bighash{'ids_'.&clutter($thisurl)}; } unless ($ids) { - my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; + my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; $ids=$bighash{$idkey}; } if ($ids) { @@ -12190,14 +11367,14 @@ sub symbverify { if (ref($encstate)) { $$encstate = $bighash{'encrypted_'.$id}; } - if (($env{'request.role.adv'}) || - ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || + if (($env{'request.role.adv'}) || + ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || ($thisurl eq '/adm/navmaps')) { - $okay=1; + $okay=1; last; - } - } - } + } + } + } } untie(%bighash); } @@ -12281,9 +11458,9 @@ sub symbread { # no filename provided? try from environment unless ($thisfn) { if ($env{'request.symb'}) { - return $env{$cache_str}=&symbclean($env{'request.symb'}); - } - $thisfn=$env{'request.filename'}; + return $env{$cache_str}=&symbclean($env{'request.symb'}); + } + $thisfn=$env{'request.filename'}; } if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } # is that filename actually a symb? Verify, clean, and return @@ -12340,7 +11517,7 @@ sub symbread { $syval=&encode_symb($bighash{'map_id_'.$mapid}, $resid,$thisfn); if (ref($possibles) eq 'HASH') { - $possibles->{$syval} = 1; + $possibles->{$syval} = 1; } if ($checkforblock) { my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); @@ -12349,7 +11526,7 @@ sub symbread { return; } } - } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { + } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { # ------------------------------------------ There is more than one possibility my $realpossible=0; foreach my $id (@possibilities) { @@ -12357,14 +11534,14 @@ sub symbread { my $canaccess; if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { $canaccess = 1; - } else { + } else { $canaccess = &allowed('bre',$file); } if ($canaccess) { my ($mapid,$resid)=split(/\./,$id); if ($bighash{'map_type_'.$mapid} ne 'page') { my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, - $resid,$thisfn); + $resid,$thisfn); if (ref($possibles) eq 'HASH') { $possibles->{$syval} = 1; } @@ -12539,6 +11716,7 @@ sub rndseed { $which =&get_rand_alg($courseid); } if (defined(&getCODE())) { + if ($which eq '64bit5') { return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); } elsif ($which eq '64bit4') { @@ -12724,7 +11902,7 @@ sub rndseed_CODE_64bit5 { sub setup_random_from_rndseed { my ($rndseed)=@_; if ($rndseed =~/([,:])/) { - my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed)); + my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed)); if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) { &Math::Random::random_set_seed_from_phrase($rndseed); } else { @@ -12981,7 +12159,7 @@ sub readfile { my $file = shift; if ( (! -e $file ) || ($file eq '') ) { return -1; }; my $fh; - open($fh,"<",$file); + open($fh,"<$file"); my $a=''; while (my $line = <$fh>) { $a .= $line; } return $a; @@ -13094,7 +12272,7 @@ sub machine_ids { sub additional_machine_domains { my @domains; - open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab"); + open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); while( my $line = <$fh>) { $line =~ s/\s//g; push(@domains,$line); @@ -13115,27 +12293,6 @@ sub default_login_domain { return $domain; } -sub shared_institution { - my ($dom) = @_; - my $same_intdom; - my $hostintdom = &internet_dom($perlvar{'lonHostID'}); - if ($hostintdom ne '') { - my %iphost = &get_iphost(); - my $primary_id = &domain($dom,'primary'); - my $primary_ip = &get_host_ip($primary_id); - if (ref($iphost{$primary_ip}) eq 'ARRAY') { - foreach my $id (@{$iphost{$primary_ip}}) { - my $intdom = &internet_dom($id); - if ($intdom eq $hostintdom) { - $same_intdom = 1; - last; - } - } - } - } - return $same_intdom; -} - # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -13186,6 +12343,8 @@ sub clutter { # &logthis("Got a blank emb style"); } } + } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) { + $thisfn='/adm/wrapper'.$thisfn; } return $thisfn; } @@ -13259,17 +12418,15 @@ sub get_dns { } my %alldns; - if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { - foreach my $dns (<$config>) { - next if ($dns !~ /^\^(\S*)/x); - my $line = $1; - my ($host,$protocol) = split(/:/,$line); - if ($protocol ne 'https') { - $protocol = 'http'; - } - $alldns{$host} = $protocol; + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + foreach my $dns (<$config>) { + next if ($dns !~ /^\^(\S*)/x); + my $line = $1; + my ($host,$protocol) = split(/:/,$line); + if ($protocol ne 'https') { + $protocol = 'http'; } - close($config); + $alldns{$host} = $protocol; } while (%alldns) { my ($dns) = sort { $b cmp $a } keys(%alldns); @@ -13280,18 +12437,18 @@ sub get_dns { delete($alldns{$dns}); next if ($response->is_error()); my @content = split("\n",$response->content); - unless ($nocache) { + unless ($nocache) { &do_cache_new('dns',$url,\@content,30*24*60*60); - } + } &$func(\@content,$hashref); return; } + close($config); my $which = (split('/',$url))[3]; &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); - if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) { - my @content = <$config>; - &$func(\@content,$hashref); - } + open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); + my @content = <$config>; + &$func(\@content,$hashref); return; } @@ -13319,7 +12476,7 @@ sub parse_dns_checksums_tab { if (ref($lines) eq 'ARRAY') { chomp(@{$lines}); my $version = shift(@{$lines}); - if ($version eq $release) { + if ($version eq $release) { foreach my $line (@{$lines}) { my ($file,$version,$shasum) = split(/,/,$line); if ($file =~ m{^/etc/httpd/conf}) { @@ -13382,7 +12539,7 @@ sub fetch_dns_checksums { my ($ignore_cache,$nocache) = @_; &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); my $fh; - if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) { + if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { my @lines = <$fh>; &parse_domain_tab(\@lines); } @@ -13434,23 +12591,8 @@ sub fetch_dns_checksums { my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); $name=~s/\s//g; if ($id && $domain && $role && $name) { - if ((exists($hostname{$id})) && ($hostname{$id} ne '')) { - my $curr = $hostname{$id}; - my $skip; - if (ref($name_to_host{$curr}) eq 'ARRAY') { - if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) { - $skip = 1; - } else { - @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}}; - } - } - unless ($skip) { - push(@{$name_to_host{$name}},$id); - } - } else { - push(@{$name_to_host{$name}},$id); - } $hostname{$id}=$name; + push(@{$name_to_host{$name}}, $id); $hostdom{$id}=$domain; if ($role eq 'library') { $libserv{$id}=$name; } if (defined($protocol)) { @@ -13483,7 +12625,7 @@ sub fetch_dns_checksums { sub load_hosts_tab { my ($ignore_cache,$nocache) = @_; &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); - open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); my @config = <$config>; &parse_hosts_tab(\@config); close($config); @@ -13745,11 +12887,11 @@ 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 2.11); } -# ------------------------------------------------------- Read loncaparev table +# ---------------------------------------------------------- Read loncaparev table { - sub load_loncaparevs { + sub load_loncaparevs { if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { - if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) { + if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { while (my $configline=<$config>) { chomp($configline); my ($hostid,$loncaparev)=split(/:/,$configline); @@ -13761,11 +12903,11 @@ sub all_loncaparevs { } } -# ----------------------------------------------------- Read serverhostID table +# ---------------------------------------------------------- Read serverhostID table { sub load_serverhomeIDs { if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { - if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { + if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { while (my $configline=<$config>) { chomp($configline); my ($name,$id)=split(/:/,$configline); @@ -13790,7 +12932,7 @@ BEGIN { # ------------------------------------------------------ Read spare server file { - open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13804,7 +12946,7 @@ BEGIN { } # ------------------------------------------------------------ Read permissions { - open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13818,7 +12960,7 @@ BEGIN { # -------------------------------------------- Read plain texts for permissions { - open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13838,7 +12980,7 @@ BEGIN { # ---------------------------------------------------------- Read package table { - open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab"); + open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { if ($configline !~ /\S/ || $configline=~/^#/) { next; } @@ -13853,11 +12995,11 @@ BEGIN { close($config); } -# --------------------------------------------------------- Read loncaparev table +# ---------------------------------------------------------- Read loncaparev table &load_loncaparevs(); -# ------------------------------------------------------- Read serverhostID table +# ---------------------------------------------------------- Read serverhostID table &load_serverhomeIDs(); @@ -13871,10 +13013,11 @@ BEGIN { my $item = $token->[1]; my $name = $token->[2]{'name'}; my $value = $token->[2]{'value'}; - if ($item ne '' && $name ne '' && $value ne '') { + my $valuematch = $token->[2]{'valuematch'}; + if ($item ne '' && $name ne '' && ($value ne '' || $valuematch ne '')) { my $release = $parser->get_text(); $release =~ s/(^\s*|\s*$ )//gx; - $needsrelease{$item.':'.$name.':'.$value} = $release; + $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch} = $release; } } } @@ -13884,7 +13027,7 @@ BEGIN { # ---------------------------------------------------------- Read managers table { if (-e "$perlvar{'lonTabDir'}/managers.tab") { - if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) { + if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { while (my $configline=<$config>) { chomp($configline); next if ($configline =~ /^\#/); @@ -13903,11 +13046,6 @@ BEGIN { } -# ------------- set default texengine (domain default overrides this) -{ - $deftex = LONCAPA::texengine(); -} - $memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], 'compress_threshold'=> 20_000, }); @@ -14149,10 +13287,12 @@ the answer, and also caches if there is =item * X -B: find the usernames behind a list of IDs -(IDs are a unique resource in a domain, there must be only 1 ID per -username, and only 1 username per ID in a specific domain) (returns -hash: id=>name,id=>name) +B: find the usernames behind either +a list of student/employee IDs or clicker IDs +(student/employee IDs are a unique resource in a domain, there must be +only 1 ID per username, and only 1 username per ID in a specific domain). +clickerIDs are not necessarily unique, as students might share clickers. +(returns hash: id=>name,id=>name) =item * X @@ -14161,7 +13301,27 @@ usernames (returns hash: name=>id,name=> =item * X -B: store away a list of names and associated IDs +B: store away a list of +names and associated student/employee IDs or clicker IDs. + +=item * +X +B: delete unwanted +student/employee ID or clicker ID username look-ups from domain. +The homeserver ($uhome) and namespace ($namespace) are optional. +If no $uhome is provided, it will be determined usig &homeserver() +for each user. If no $namespace is provided, the default is ids. + +=item * +X +B: update +clicker ID-to-username look-ups in clickers.db on library server. +Permitted actions are add or del (i.e., add or delete). The +clickers.db contains clickerID as keys (escaped), and each corresponding +value is an escaped comma-separated list of usernames (for whom the +library server is the homeserver), who registered that particular ID. +If $critical is true, the update will be sent via &critical, otherwise +&reply() will be used. =item * X @@ -14209,13 +13369,13 @@ The first argument is required, all othe $priv is the privilege being checked. $uri contains additional information about what is being checked for access (e.g., -URL, course ID etc.). +URL, course ID etc.). $symb is the unique resource instance identifier in a course; if needed, -but not provided, it will be retrieved via a call to &symbread(). -$role is the role for which a priv is being checked (only used if priv is evb). -$clientip is the user's IP address (only used when checking for access to portfolio +but not provided, it will be retrieved via a call to &symbread(). +$role is the role for which a priv is being checked (only used if priv is evb). +$clientip is the user's IP address (only used when checking for access to portfolio files). -$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This +$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This prevents recursive calls to &allowed. F: full access @@ -14243,10 +13403,9 @@ in which case the null string is returne =item * -definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role; -define a custom role rolename set privileges in format of lonTabs/roles.tab -for system, domain, and course level. $uname and $udom are optional (current -user's username and domain will be used when either of $uname or $udom are absent. +definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom +role rolename set privileges in format of lonTabs/roles.tab for system, domain, +and course level =item * @@ -14277,9 +13436,9 @@ provided for types, will default to retu =item * in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if -user: $uname:$udom has a role in the course: $cdom_$cnum. +user: $uname:$udom has a role in the course: $cdom_$cnum. -Additional optional arguments are: $type (if role checking is to be restricted +Additional optional arguments are: $type (if role checking is to be restricted to certain user status types -- previous (expired roles), active (currently available roles) or future (roles available in the future), and $hideprivileged -- if true will not report course roles for users who @@ -14450,8 +13609,6 @@ Inputs: =item $credits, number of credits student will earn from this class -=item $instsec, institutional course section code for student - =back @@ -14518,7 +13675,7 @@ values that are the resource value. I b versions are also returned. get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's -supplemental content area. This routine caches the number of files for +supplemental content area. This routine caches the number of files for 10 minutes. =back @@ -14555,88 +13712,6 @@ Returns: =back -=head2 Bubblesheet Configuration - -=over 4 - -=item * - -get_scantron_config($which) - -$which - the name of the configuration to parse from the file. - -Parses and returns the bubblesheet configuration line selected as a -hash of configuration file fields. - - -Returns: - If the named configuration is not in the file, an empty - hash is returned. - - a hash with the fields - name - internal name for the this configuration setup - description - text to display to operator that describes this config - CODElocation - if 0 or the string 'none' - - no CODE exists for this config - if -1 || the string 'letter' - - a CODE exists for this config and is - a string of letters - Unsupported value (but planned for future support) - if a positive integer - - The CODE exists as the first n items from - the question section of the form - if the string 'number' - - The CODE exists for this config and is - a string of numbers - CODEstart - (only matter if a CODE exists) column in the line where - the CODE starts - CODElength - length of the CODE - IDstart - column where the student/employee ID starts - IDlength - length of the student/employee ID info - Qstart - column where the information from the bubbled - 'questions' start - Qlength - number of columns comprising a single bubble line from - the sheet. (usually either 1 or 10) - Qon - either a single character representing the character used - to signal a bubble was chosen in the positional setup, or - the string 'letter' if the letter of the chosen bubble is - in the final, or 'number' if a number representing the - chosen bubble is in the file (1->A 0->J) - Qoff - the character used to represent that a bubble was - left blank - PaperID - if the scanning process generates a unique number for each - sheet scanned the column that this ID number starts in - PaperIDlength - number of columns that comprise the unique ID number - for the sheet of paper - FirstName - column that the first name starts in - FirstNameLength - number of columns that the first name spans - LastName - column that the last name starts in - LastNameLength - number of columns that the last name spans - BubblesPerRow - number of bubbles available in each row used to - bubble an answer. (If not specified, 10 assumed). - - -=item * - -get_scantronformat_file($cdom) - -$cdom - the course's domain (optional); if not supplied, uses -domain for current $env{'request.course.id'}. - -Returns an array containing lines from the scantron format file for -the domain of the course. - -If a url for a custom.tab file is listed in domain's configuration.db, -lines are from this file. - -Otherwise, if a default.tab has been published in RES space by the -domainconfig user, lines are from this file. - -Otherwise, fall back to getting lines from the legacy file on the -local server: /home/httpd/lonTabs/default_scantronformat.tab - -=back - =head2 Resource Subroutines =over 4 @@ -14703,20 +13778,20 @@ will be stored for query =item * -symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) : -return symbolic list entry (all arguments optional). +symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) : +return symbolic list entry (all arguments optional). -Args: filename is the filename (including path) for the file for which a symb -is required; donotrecurse, if true will prevent calls to allowed() being made -to check access status if more than one resource was found in the bighash -(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of -a randompick); ignorecachednull, if true will prevent a symb of '' being +Args: filename is the filename (including path) for the file for which a symb +is required; donotrecurse, if true will prevent calls to allowed() being made +to check access status if more than one resource was found in the bighash +(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of +a randompick); ignorecachednull, if true will prevent a symb of '' being returned if $env{$cache_str} is defined as ''; checkforblock if true will cause possible symbs to be checked to determine if they are subject to content blocking, if so they will not be included as possible symbs; possibles is a -ref to a hash, which, as a side effect, will be populated with all possible +ref to a hash, which, as a side effect, will be populated with all possible symbs (content blocking not tested). - + returns the data handle =item * @@ -14726,9 +13801,9 @@ and is a possible symb for the URL in $t resource that the user accessed using /enc/ returns a 1 on success, 0 on failure, user must be in a course, as it assumes the existence of the course initial hash, and uses $env('request.course.id'}. The third -arg is an optional reference to a scalar. If this arg is passed in the +arg is an optional reference to a scalar. If this arg is passed in the call to symbverify, it will be set to 1 if the symb has been set to be -encrypted; otherwise it will be null. +encrypted; otherwise it will be null. =item * @@ -14781,13 +13856,13 @@ expirespread($uname,$udom,$stype,$usymb) devalidate($symb) : devalidate temporary spreadsheet calculations, forcing spreadsheet to reevaluate the resource scores next time. -=item * +=item * can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource, when viewing in course context. input: six args -- filename (decluttered), course number, course domain, - url, symb (if registered) and group (if this is a + url, symb (if registered) and group (if this is a group item -- e.g., bulletin board, group page etc.). output: array of five scalars -- @@ -14795,15 +13870,15 @@ when viewing in course context. $home -- homeserver of resource (i.e., for author if published, or course if uploaded.). $switchserver -- 1 if server switch will be needed. - $forceedit -- 1 if icon/link should be to go to edit mode + $forceedit -- 1 if icon/link should be to go to edit mode $forceview -- 1 if icon/link should be to go to view mode =item * is_course_upload($file,$cnum,$cdom) -Used in course context to determine if current file was uploaded to -the course (i.e., would be found in /userfiles/docs on the course's +Used in course context to determine if current file was uploaded to +the course (i.e., would be found in /userfiles/docs on the course's homeserver. input: 3 args -- filename (decluttered), course number and course domain. @@ -14817,20 +13892,20 @@ homeserver. =item * -store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash +store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash permanently for this url; hashref needs to be given and should be a \%hashname; the remaining args aren't required and if they aren't passed or are '' they will -be derived from the env (with the exception of $laststore, which is an +be derived from the env (with the exception of $laststore, which is an optional arg used when a user's submission is stored in grading). $laststore is $version=$timestamp, where $version is the most recent version number retrieved for the corresponding $symb in the $namespace db file, and $timestamp is the timestamp for that transaction (UNIX time). -$laststore is currently only passed when cstore() is called by +$laststore is currently only passed when cstore() is called by structuretags::finalize_storage(). =item * -cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store +cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store but uses critical subroutine =item * @@ -14968,7 +14043,7 @@ server ($udom and $uhome are optional) =item * -get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults +get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults for: authentication, language, quotas, timezone, date locale, and portal URL in the target domain. @@ -15023,7 +14098,7 @@ for course's uploaded content. =over =item -canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, +canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota =back @@ -15034,7 +14109,7 @@ on your servers. =over -=item +=item remotesessions, hostedsessions =back @@ -15042,10 +14117,10 @@ remotesessions, hostedsessions =back In cases where a domain coordinator has never used the "Set Domain Configuration" -utility to create a configuration.db file on a domain's primary library server +utility to create a configuration.db file on a domain's primary library server only the following domain defaults: auth_def, auth_arg_def, lang_def -- corresponding values are authentication type (internal, krb4, krb5, -or localauth), initial password or a kerberos realm, language (e.g., en-us) -- +or localauth), initial password or a kerberos realm, language (e.g., en-us) -- will be available. Values are retrieved from cache (if current), unless the optional $ignore_cache arg is true, or from domain's configuration.db (if available), or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab. @@ -15328,7 +14403,6 @@ userspace, probably shouldn't be called 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. - if hashref, and context is scantron, will convert csv format to standard format 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 @@ -15474,8 +14548,8 @@ Returns: get_timebased_id(): -Attempts to get a unique timestamp-based suffix for use with items added to a -course via the Course Editor (e.g., folders, composite pages, +Attempts to get a unique timestamp-based suffix for use with items added to a +course via the Course Editor (e.g., folders, composite pages, group bulletin boards). Args: (first three required; six others optional) @@ -15486,24 +14560,24 @@ Args: (first three required; six others 2. keyid (alphanumeric): name of temporary locking key in hash, e.g., num, boardids -3. namespace: name of gdbm file used to store suffixes already assigned; +3. namespace: name of gdbm file used to store suffixes already assigned; file will be named nohist_namespace.db 4. cdom: domain of course; default is current course domain from %env 5. cnum: course number; default is current course number from %env -6. idtype: set to concat if an additional digit is to be appended to the +6. idtype: set to concat if an additional digit is to be appended to the unix timestamp to form the suffix, if the plain timestamp is already - in use. Default is to not do this, but simply increment the unix + in use. Default is to not do this, but simply increment the unix timestamp by 1 until a unique key is obtained. 7. who: holder of locking key; defaults to user:domain for user. -8. locktries: number of attempts to obtain a lock (sleep of 1s before +8. locktries: number of attempts to obtain a lock (sleep of 1s before retrying); default is 3. -9. maxtries: number of attempts to obtain a unique suffix; default is 20. +9. maxtries: number of attempts to obtain a unique suffix; default is 20. Returns: 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.