--- loncom/lonnet/perl/lonnet.pm 2009/01/02 22:45:43 1.982 +++ loncom/lonnet/perl/lonnet.pm 2010/03/26 21:27:41 1.1056.2.2 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.982 2009/01/02 22:45:43 raeburn Exp $ +# $Id: lonnet.pm,v 1.1056.2.2 2010/03/26 21:27:41 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -75,7 +75,6 @@ use LWP::UserAgent(); use HTTP::Date; use Image::Magick; -# use Date::Parse; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol); @@ -93,14 +92,13 @@ use Time::HiRes qw( gettimeofday tv_inte use Cache::Memcached; use Digest::MD5; use Math::Random; +use File::MMagic; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; my $readit; my $max_connection_retries = 10; # Or some such value. -my $upload_photo_form = 0; #Variable to check when user upload a photo 0=not 1=true - require Exporter; our @ISA = qw (Exporter); @@ -150,7 +148,8 @@ sub logthis { my $now=time; my $local=localtime($now); if (open(my $fh,">>$execdir/logs/lonnet.log")) { - print $fh "$local ($$): $message\n"; + my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. + print $fh $logstring; close($fh); } return 1; @@ -181,6 +180,47 @@ sub create_connection { return 0; } +sub get_server_timezone { + my ($cnum,$cdom) = @_; + my $home=&homeserver($cnum,$cdom); + if ($home ne 'no_host') { + my $cachetime = 24*3600; + my ($timezone,$cached)=&is_cached_new('servertimezone',$home); + if (defined($cached)) { + return $timezone; + } else { + my $timezone = &reply('servertimezone',$home); + return &do_cache_new('servertimezone',$home,$timezone,$cachetime); + } + } +} + +sub get_server_loncaparev { + my ($dom,$lonhost) = @_; + if (defined($lonhost)) { + if (!defined(&hostname($lonhost))) { + undef($lonhost); + } + } + if (!defined($lonhost)) { + if (defined(&domain($dom,'primary'))) { + $lonhost=&domain($dom,'primary'); + if ($lonhost eq 'no_host') { + undef($lonhost); + } + } + } + if (defined($lonhost)) { + my $cachetime = 24*3600; + my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost); + if (defined($cached)) { + return $loncaparev; + } else { + my $loncaparev = &reply('serverloncaparev',$lonhost); + return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime); + } + } +} # -------------------------------------------------- Non-critical communication sub subreply { @@ -512,7 +552,7 @@ sub appenv { # ----------------------------------------------------- Delete from Environment sub delenv { - my $delthis=shift; + my ($delthis,$regexp) = @_; if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { &logthis("WARNING: ". "Attempt to delete from environment ".$delthis); @@ -525,10 +565,17 @@ sub delenv { tie(my %disk_env,'GDBM_File',$env{'user.environment'}, (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { foreach my $key (keys(%disk_env)) { - if ($key=~/^\Q$delthis\E/) { - delete($env{$key}); - delete($disk_env{$key}); - } + if ($regexp) { + if ($key=~/^$delthis/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } else { + if ($key=~/^\Q$delthis\E/) { + delete($env{$key}); + delete($disk_env{$key}); + } + } } untie(%disk_env); } @@ -670,7 +717,12 @@ sub spareserver { if ($protocol{$spare_server} eq 'https') { $protocol = $protocol{$spare_server}; } - $spare_server = $protocol.'://'.&hostname($spare_server); + if (defined($spare_server)) { + my $hostname = &hostname($spare_server); + if (defined($hostname)) { + $spare_server = $protocol.'://'.$hostname; + } + } } return $spare_server; } @@ -731,7 +783,8 @@ sub changepass { my ($uname,$udom,$currentpass,$newpass,$server,$context)=@_; $currentpass = &escape($currentpass); $newpass = &escape($newpass); - my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context", + my $lonhost = $perlvar{'lonHostID'}; + my $answer = reply("encrypt:passwd:$udom:$uname:$currentpass:$newpass:$context:$lonhost", $server); if (! $answer) { &logthis("No reply on password change request to $server ". @@ -756,6 +809,9 @@ sub changepass { } elsif ($answer =~ "^refused") { &logthis("$server refused to change $uname in $udom password because ". "it was sent an unencrypted request to change the password."); + } elsif ($answer =~ "invalid_client") { + &logthis("$server refused to change $uname in $udom password because ". + "it was a reset by e-mail originating from an invalid server."); } return $answer; } @@ -905,7 +961,21 @@ sub idput { } } -# ------------------------------------------- get items from domain db files +# ------------------------------dump from db file owned by domainconfig user +sub dump_dom { + my ($namespace,$udom,$regexp,$range)=@_; + if (!$udom) { + $udom=$env{'user.domain'}; + } + my %returnhash; + if ($udom) { + my $uname = &get_domainconfiguser($udom); + %returnhash = &dump($namespace,$udom,$uname,$regexp,$range); + } + return %returnhash; +} + +# ------------------------------------------ get items from domain db files sub get_dom { my ($namespace,$storearr,$udom,$uhome)=@_; @@ -979,30 +1049,71 @@ sub put_dom { } } +# --------------------- newput for items in db file owned by domainconfig user +sub newput_dom { + my ($namespace,$storehash,$udom) = @_; + my $result; + if (!$udom) { + $udom=$env{'user.domain'}; + } + if ($udom) { + my $uname = &get_domainconfiguser($udom); + $result = &newput($namespace,$storehash,$udom,$uname); + } + return $result; +} + +# --------------------- delete for items in db file owned by domainconfig user +sub del_dom { + my ($namespace,$storearr,$udom)=@_; + if (ref($storearr) eq 'ARRAY') { + if (!$udom) { + $udom=$env{'user.domain'}; + } + if ($udom) { + my $uname = &get_domainconfiguser($udom); + return &del($namespace,$storearr,$udom,$uname); + } + } +} + +# ----------------------------------construct domainconfig user for a domain +sub get_domainconfiguser { + my ($udom) = @_; + return $udom.'-domainconfig'; +} + sub retrieve_inst_usertypes { my ($udom) = @_; my (%returnhash,@order); - if (defined(&domain($udom,'primary'))) { - my $uhome=&domain($udom,'primary'); - my $rep=&reply("inst_usertypes:$udom",$uhome); - if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { - &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); - return (\%returnhash,\@order); - } - my ($hashitems,$orderitems) = split(/:/,$rep); - my @pairs=split(/\&/,$hashitems); - foreach my $item (@pairs) { - my ($key,$value)=split(/=/,$item,2); - $key = &unescape($key); - next if ($key =~ /^error: 2 /); - $returnhash{$key}=&thaw_unescape($value); - } - my @esc_order = split(/\&/,$orderitems); - foreach my $item (@esc_order) { - push(@order,&unescape($item)); - } + my %domdefs = &Apache::lonnet::get_domain_defaults($udom); + if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && + (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { + %returnhash = %{$domdefs{'inststatustypes'}}; + @order = @{$domdefs{'inststatusorder'}}; } else { - &logthis("get_dom failed - no primary domain server for $udom"); + if (defined(&domain($udom,'primary'))) { + my $uhome=&domain($udom,'primary'); + my $rep=&reply("inst_usertypes:$udom",$uhome); + if ($rep =~ /^(con_lost|error|no_such_host|refused)/) { + &logthis("get_dom failed - $rep returned from $uhome in domain: $udom"); + return (\%returnhash,\@order); + } + my ($hashitems,$orderitems) = split(/:/,$rep); + my @pairs=split(/\&/,$hashitems); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash{$key}=&thaw_unescape($value); + } + my @esc_order = split(/\&/,$orderitems); + foreach my $item (@esc_order) { + push(@order,&unescape($item)); + } + } else { + &logthis("get_dom failed - no primary domain server for $udom"); + } } return (\%returnhash,\@order); } @@ -1239,13 +1350,15 @@ sub get_domain_defaults { } my %domdefaults; my %domconfig = - &Apache::lonnet::get_dom('configuration',['defaults','quotas'],$domain); + &Apache::lonnet::get_dom('configuration',['defaults','quotas', + 'requestcourses','inststatus', + 'coursedefaults'],$domain); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; - $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'} + $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -1264,6 +1377,21 @@ sub get_domain_defaults { } } } + if (ref($domconfig{'requestcourses'}) eq 'HASH') { + foreach my $item ('official','unofficial','community') { + $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; + } + } + if (ref($domconfig{'inststatus'}) eq 'HASH') { + foreach my $item ('inststatustypes','inststatusorder') { + $domdefaults{$item} = $domconfig{'inststatus'}{$item}; + } + } + if (ref($domconfig{'coursedefaults'}) eq 'HASH') { + foreach my $item ('canuse_pdfforms') { + $domdefaults{$item} = $domconfig{'coursedefaults'}{$item}; + } + } &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults, $cachetime); return %domdefaults; @@ -1594,12 +1722,17 @@ sub userenvironment { } $items=~s/\&$//; my %returnhash=(); - my @answer=split(/\&/, - &reply('get:'.$udom.':'.$unam.':environment:'.$items, - &homeserver($unam,$udom))); - my $i; - for ($i=0;$i<=$#what;$i++) { - $returnhash{$what[$i]}=&unescape($answer[$i]); + my $uhome = &homeserver($unam,$udom); + unless ($uhome eq 'no_host') { + my @answer=split(/\&/, + &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome)); + if ($#answer==0 && $answer[0] =~ /^(con_lost|error:|no_such_host)/i) { + return %returnhash; + } + my $i; + for ($i=0;$i<=$#what;$i++) { + $returnhash{$what[$i]}=&unescape($answer[$i]); + } } return %returnhash; } @@ -1795,6 +1928,8 @@ sub ssi_body { if ($filelink=~/^https?\:/) { ($output,$response)=&externalssi($filelink); } else { + $filelink .= $filelink=~/\?/ ? '&' : '?'; + $filelink .= 'inhibitmenu=yes'; ($output,$response)=&ssi($filelink,%form); } $output=~s|//(\s*)?\s||gs; @@ -1838,7 +1973,7 @@ sub ssi { &Apache::lonenc::check_encrypt(\$fn); if (%form) { $request=new HTTP::Request('POST',&absolute_url().$fn); - $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form)); + $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form))); } else { $request=new HTTP::Request('GET',&absolute_url().$fn); } @@ -1936,9 +2071,13 @@ sub process_coursefile { print $fh $env{'form.'.$source}; close($fh); if ($parser eq 'parse') { - my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); - unless ($parse_result eq 'ok') { - &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); + my $mm = new File::MMagic; + my $mime_type = $mm->checktype_filename($filepath.'/'.$fname); + if ($mime_type eq 'text/html') { + my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase); + unless ($parse_result eq 'ok') { + &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result); + } } } $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file, @@ -2015,13 +2154,42 @@ sub clean_filename { $fname=~s/\.(\d+)(?=\.)/_$1/g; return $fname; } - -#Wrapper function for userphotoupload -sub userphotoupload -{ - my($formname,$subdir) = @_; - $upload_photo_form = 1; - return &userfileupload($formname,undef,$subdir); +# 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 +# not exceed $resizewidth and $resizeheight. + +sub resizeImage { + my ($img_path,$resizewidth,$resizeheight) = @_; + my $ima = Image::Magick->new; + my $resized; + if (-e $img_path) { + $ima->Read($img_path); + if (($resizewidth =~ /^\d+$/) && ($resizeheight > 0)) { + my $width = $ima->Get('width'); + my $height = $ima->Get('height'); + if ($width > $resizewidth) { + my $factor = $width/$resizewidth; + my $newheight = $height/$factor; + $ima->Scale(width=>$resizewidth,height=>$newheight); + $resized = 1; + } + } + if (($resizeheight =~ /^\d+$/) && ($resizeheight > 0)) { + my $width = $ima->Get('width'); + my $height = $ima->Get('height'); + if ($height > $resizeheight) { + my $factor = $height/$resizeheight; + my $newwidth = $width/$factor; + $ima->Scale(width=>$newwidth,height=>$resizeheight); + $resized = 1; + } + } + if ($resized) { + $ima->Write($img_path); + } + } + return; } # --------------- Take an uploaded file and put it into the userfiles directory @@ -2037,14 +2205,15 @@ sub userphotoupload # $dsetudom - domain for permanaent storage of uploaded file # $thumbwidth - width (pixels) of thumbnail to make for uploaded image # $thumbheight - height (pixels) of thumbnail to make for uploaded image +# $resizewidth - width (pixels) to which to resize uploaded image +# $resizeheight - height (pixels) to which to resize uploaded image # # output: url of file in userspace, or error: # or /adm/notfound.html if failure to upload occurse - sub userfileupload { my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase,$destuname, - $destudom,$thumbwidth,$thumbheight)=@_; + $destudom,$thumbwidth,$thumbheight,$resizewidth,$resizeheight)=@_; if (!defined($subdir)) { $subdir='unknown'; } my $fname=$env{'form.'.$formname.'.filename'}; $fname=&clean_filename($fname); @@ -2082,16 +2251,20 @@ sub userfileupload { close($fh); return $fullpath.'/'.$fname; } - + if ($subdir eq 'scantron') { + $fname = 'scantron_orig_'.$fname; + } else { # Create the directory if not present - $fname="$subdir/$fname"; + $fname="$subdir/$fname"; + } if ($coursedoc) { my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'}; my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'}; if ($env{'form.folder'} =~ m/^(default|supplemental)/) { return &finishuserfileupload($docuname,$docudom, $formname,$fname,$parser,$allfiles, - $codebase,$thumbwidth,$thumbheight); + $codebase,$thumbwidth,$thumbheight, + $resizewidth,$resizeheight); } else { $fname=$env{'form.folder'}.'/'.$fname; return &process_coursefile('uploaddoc',$docuname,$docudom, @@ -2103,7 +2276,8 @@ sub userfileupload { my $docudom=$destudom; return &finishuserfileupload($docuname,$docudom,$formname,$fname, $parser,$allfiles,$codebase, - $thumbwidth,$thumbheight); + $thumbwidth,$thumbheight, + $resizewidth,$resizeheight); } else { my $docuname=$env{'user.name'}; @@ -2114,15 +2288,17 @@ sub userfileupload { } return &finishuserfileupload($docuname,$docudom,$formname,$fname, $parser,$allfiles,$codebase, - $thumbwidth,$thumbheight); + $thumbwidth,$thumbheight, + $resizewidth,$resizeheight); } } sub finishuserfileupload { my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase, - $thumbwidth,$thumbheight) = @_; + $thumbwidth,$thumbheight,$resizewidth,$resizeheight) = @_; my $path=$docudom.'/'.$docuname.'/'; my $filepath=$perlvar{'lonDocRoot'}; + my ($fnamepath,$file,$fetchthumb); $file=$fname; if ($fname=~m|/|) { @@ -2137,6 +2313,7 @@ sub finishuserfileupload { mkdir($filepath,0777); } } + # Save the file { if (!open(FH,'>'.$filepath.'/'.$file)) { @@ -2150,32 +2327,24 @@ sub finishuserfileupload { return '/adm/notfound.html'; } close(FH); - if($upload_photo_form==1) - { - my $ima = Image::Magick->new; - $ima->Read($filepath.'/'.$file); - if($ima->Get('width') > 300) - { - my $factor = $ima->Get('width')/300; - $ima->Scale( width=>300, height=>$ima->Get('height')/$factor ); - } - if($ima->Get('height') > 400) - { - my $factor = $ima->Get('height')/400; - $ima->Scale( width=>$ima->Get('width')/$factor, height=>400); - } - - - $ima->Write($filepath.'/'.$file); - $upload_photo_form = 0; + if ($resizewidth && $resizeheight) { + my $mm = new File::MMagic; + my $mime_type = $mm->checktype_filename($filepath.'/'.$file); + if ($mime_type =~ m{^image/}) { + &resizeImage($filepath.'/'.$file,$resizewidth,$resizeheight); + } } } if ($parser eq 'parse') { - my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles, - $codebase); - unless ($parse_result eq 'ok') { - &logthis('Failed to parse '.$filepath.$file. - ' for embedded media: '.$parse_result); + my $mm = new File::MMagic; + my $mime_type = $mm->checktype_filename($filepath.'/'.$file); + if ($mime_type eq 'text/html') { + my $parse_result = &extract_embedded_items($filepath.'/'.$file, + $allfiles,$codebase); + unless ($parse_result eq 'ok') { + &logthis('Failed to parse '.$filepath.$file. + ' for embedded media: '.$parse_result); + } } } if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { @@ -2190,7 +2359,7 @@ sub finishuserfileupload { # Notify homeserver to grep it # - my $docuhome=&homeserver($docuname,$docudom); + my $docuhome=&homeserver($docuname,$docudom); my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome); if ($fetchresult eq 'ok') { if ($fetchthumb) { @@ -2322,21 +2491,21 @@ sub add_filetype { } sub removeuploadedurl { - my ($url)=@_; - my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); + my ($url)=@_; + my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); return &removeuserfile($uname,$udom,$fname); } sub removeuserfile { my ($docuname,$docudom,$fname)=@_; - my $home=&homeserver($docuname,$docudom); + my $home=&homeserver($docuname,$docudom); my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home); - if ($result eq 'ok') { + if ($result eq 'ok') { if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) { my $metafile = $fname.'.meta'; my $metaresult = &removeuserfile($docuname,$docudom,$metafile); my $url = "/uploaded/$docudom/$docuname/$fname"; - my ($file,$group) = (&parse_portfolio_url($url))[3,4]; + my ($file,$group) = (&parse_portfolio_url($url))[3,4]; my $sqlresult = &update_portfolio_table($docuname,$docudom,$file, 'portfolio_metadata',$group, @@ -2479,7 +2648,7 @@ sub flushcourselogs { # Reverse lookup of domain roles (dc, ad, li, sc, au) # my %domrolebuffer = (); - foreach my $entry (keys %domainrolehash) { + foreach my $entry (keys(%domainrolehash)) { my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry); if ($domrolebuffer{$rudom}) { $domrolebuffer{$rudom}.='&'.&escape($entry). @@ -2584,7 +2753,7 @@ sub userrolelog { if (($trole=~/^ca/) || ($trole=~/^aa/) || ($trole=~/^in/) || ($trole=~/^cc/) || ($trole=~/^ep/) || ($trole=~/^cr/) || - ($trole=~/^ta/)) { + ($trole=~/^ta/) || ($trole=~/^co/)) { my (undef,$rudom,$runame,$rsec)=split(/\//,$area); $userrolehash {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} @@ -2593,7 +2762,8 @@ sub userrolelog { if (($env{'request.role'} =~ /dc\./) && (($trole=~/^au/) || ($trole=~/^in/) || ($trole=~/^cc/) || ($trole=~/^ep/) || - ($trole=~/^cr/) || ($trole=~/^ta/))) { + ($trole=~/^cr/) || ($trole=~/^ta/) || + ($trole=~/^co/))) { $userrolehash {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} =$tend.':'.$tstart; @@ -2614,7 +2784,8 @@ sub courserolelog { if (($trole eq 'cc') || ($trole eq 'in') || ($trole eq 'ep') || ($trole eq 'ad') || ($trole eq 'ta') || ($trole eq 'st') || - ($trole=~/^cr/) || ($trole eq 'gr')) { + ($trole=~/^cr/) || ($trole eq 'gr') || + ($trole eq 'co')) { if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { my $cdom = $1; my $cnum = $2; @@ -2634,6 +2805,9 @@ sub courserolelog { $storehash{'section'} = $sec; } &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); + if (($trole ne 'st') || ($sec ne '')) { + &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); + } } } return; @@ -2643,6 +2817,7 @@ sub get_course_adv_roles { my ($cid,$codes) = @_; $cid=$env{'request.course.id'} unless (defined($cid)); my %coursehash=&coursedescription($cid); + my $crstype = &Apache::loncommon::course_type($cid); my %nothide=(); foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { if ($user !~ /:/) { @@ -2655,15 +2830,29 @@ sub get_course_adv_roles { my %dumphash= &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'}); my $now=time; - foreach my $entry (keys %dumphash) { + my %privileged; + foreach my $entry (keys(%dumphash)) { my ($tend,$tstart)=split(/\:/,$dumphash{$entry}); if (($tstart) && ($tstart<0)) { next; } if (($tend) && ($tend<$now)) { next; } if (($tstart) && ($now<$tstart)) { next; } my ($role,$username,$domain,$section)=split(/\:/,$entry); if ($username eq '' || $domain eq '') { next; } - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { next; } + unless (ref($privileged{$domain}) eq 'HASH') { + my %dompersonnel = + &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); + $privileged{$domain} = {}; + foreach my $server (keys(%dompersonnel)) { + if (ref($dompersonnel{$server}) eq 'HASH') { + foreach my $user (keys(%{$dompersonnel{$server}})) { + my ($trole,$uname,$udom) = split(/:/,$user); + $privileged{$udom}{$uname} = 1; + } + } + } + } + if ((exists($privileged{$domain}{$username})) && + (!$nothide{$username.':'.$domain})) { next; } if ($role eq 'cr') { next; } if ($codes) { if ($section) { $role .= ':'.$section; } @@ -2673,7 +2862,7 @@ sub get_course_adv_roles { $returnhash{$role}=$username.':'.$domain; } } else { - my $key=&plaintext($role); + my $key=&plaintext($role,$crstype); if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; } if ($returnhash{$key}) { $returnhash{$key}.=','.$username.':'.$domain; @@ -2708,6 +2897,7 @@ sub get_my_roles { } my %returnhash=(); my $now=time; + my %privileged; foreach my $entry (keys(%dumphash)) { my ($role,$tend,$tstart); if ($context eq 'userroles') { @@ -2756,9 +2946,32 @@ sub get_my_roles { } } if ($hidepriv) { - if ((&privileged($username,$domain)) && - (!$nothide{$username.':'.$domain})) { - next; + if ($context eq 'userroles') { + if ((&privileged($username,$domain)) && + (!$nothide{$username.':'.$domain})) { + next; + } + } else { + unless (ref($privileged{$domain}) eq 'HASH') { + my %dompersonnel = + &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now); + $privileged{$domain} = {}; + if (keys(%dompersonnel)) { + foreach my $server (keys(%dompersonnel)) { + if (ref($dompersonnel{$server}) eq 'HASH') { + foreach my $user (keys(%{$dompersonnel{$server}})) { + my ($trole,$uname,$udom) = split(/:/,$user); + $privileged{$udom}{$uname} = $trole; + } + } + } + } + } + if (exists($privileged{$domain}{$username})) { + if (!$nothide{$username.':'.$domain}) { + next; + } + } } } if ($withsec) { @@ -2806,6 +3019,7 @@ sub getannounce { sub courseidput { my ($domain,$storehash,$coursehome,$caller) = @_; + return unless (ref($storehash) eq 'HASH'); my $outcome; if ($caller eq 'timeonly') { my $cids = ''; @@ -2844,7 +3058,8 @@ sub courseidput { sub courseiddump { my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter, $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, - $selfenrollonly,$catfilter,$showhidden,$caller)=@_; + $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, + $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -2863,7 +3078,10 @@ sub courseiddump { ':'.&escape($coursefilter).':'.&escape($typefilter). ':'.&escape($regexp_ok).':'.$as_hash.':'. &escape($selfenrollonly).':'.&escape($catfilter).':'. - $showhidden.':'.$caller,$tryserver); + $showhidden.':'.$caller.':'.&escape($cloner).':'. + &escape($cc_clone).':'.$cloneonly.':'. + &escape($createdbefore).':'.&escape($createdafter).':'. + &escape($creationcontext),$tryserver); my @pairs=split(/\&/,$rep); foreach my $item (@pairs) { my ($key,$value)=split(/\=/,$item,2); @@ -2878,7 +3096,7 @@ sub courseiddump { for (my $i=0; $i<@responses; $i++) { $returnhash{$key}{$items[$i]} = &unescape($responses[$i]); } - } + } } } } @@ -2886,6 +3104,49 @@ sub courseiddump { return %returnhash; } +sub courselastaccess { + my ($cdom,$cnum,$hostidref) = @_; + my %returnhash; + if ($cdom && $cnum) { + my $chome = &homeserver($cnum,$cdom); + if ($chome ne 'no_host') { + my $rep = &reply('courselastaccess:'.$cdom.':'.$cnum,$chome); + &extract_lastaccess(\%returnhash,$rep); + } + } else { + if (!$cdom) { $cdom=''; } + my %libserv = &all_library(); + foreach my $tryserver (keys(%libserv)) { + if (ref($hostidref) eq 'ARRAY') { + next unless (grep(/^\Q$tryserver\E$/,@{$hostidref})); + } + if (($cdom eq '') || (&host_domain($tryserver) eq $cdom)) { + my $rep = &reply('courselastaccess:'.&host_domain($tryserver).':',$tryserver); + &extract_lastaccess(\%returnhash,$rep); + } + } + } + return %returnhash; +} + +sub extract_lastaccess { + my ($returnhash,$rep) = @_; + if (ref($returnhash) eq 'HASH') { + unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || + $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' || + $rep eq '') { + my @pairs=split(/\&/,$rep); + foreach my $item (@pairs) { + my ($key,$value)=split(/\=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + $returnhash->{$key} = &thaw_unescape($value); + } + } + } + return; +} + # ---------------------------------------------------------- DC e-mail sub dcmailput { @@ -2918,10 +3179,10 @@ sub dcmaildump { sub get_domain_roles { my ($dom,$roles,$startdate,$enddate)=@_; - if (undef($startdate) || $startdate eq '') { + if ((!defined($startdate)) || ($startdate eq '')) { $startdate = '.'; } - if (undef($enddate) || $enddate eq '') { + if ((!defined($enddate)) || ($enddate eq '')) { $enddate = '.'; } my $rolelist; @@ -3328,7 +3589,7 @@ sub tmpreset { if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', &GDBM_WRCREAT(),0640)) { - foreach my $key (keys %hash) { + foreach my $key (keys(%hash)) { if ($key=~ /:$symb/) { delete($hash{$key}); } @@ -3611,7 +3872,10 @@ sub privileged { my ($username,$domain)=@_; my $rolesdump=&reply("dump:$domain:$username:roles", &homeserver($username,$domain)); - if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return 0; } + if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || + ($rolesdump =~ /^error:/)) { + return 0; + } my $now=time; if ($rolesdump ne '') { foreach my $entry (split(/&/,$rolesdump)) { @@ -3639,13 +3903,15 @@ sub privileged { sub rolesinit { my ($domain,$username,$authhost)=@_; - my %userroles; + my $now=time; + my %userroles = ('user.login.time' => $now); my $rolesdump=reply("dump:$domain:$username:roles",$authhost); - if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; } + if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || + ($rolesdump =~ /^error:/)) { + return \%userroles; + } my %allroles=(); my %allgroups=(); - my $now=time; - %userroles = ('user.login.time' => $now); my $group_privs; if ($rolesdump ne '') { @@ -3711,6 +3977,9 @@ sub custom_roleprivs { if (($rdummy ne 'con_lost') && ($roledef ne '')) { my ($syspriv,$dompriv,$coursepriv)=split(/\_/,$roledef); if (defined($syspriv)) { + if ($trest =~ /^$match_community$/) { + $syspriv =~ s/bre\&S//; + } $$allroles{'cm./'}.=':'.$syspriv; $$allroles{$spec.'./'}.=':'.$syspriv; } @@ -3764,7 +4033,7 @@ sub set_userprivs { my $adv=0; my %grouproles = (); if (keys(%{$allgroups}) > 0) { - foreach my $role (keys %{$allroles}) { + foreach my $role (keys(%{$allroles})) { my ($trole,$area,$sec,$extendedarea); if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { $trole = $1; @@ -3807,6 +4076,94 @@ sub set_userprivs { return ($author,$adv); } +sub role_status { + my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; + my @pwhere = (); + if (exists($env{$rolekey}) && $env{$rolekey} ne '') { + (undef,undef,$$role,@pwhere)=split(/\./,$rolekey); + unless (!defined($$role) || $$role eq '') { + $$where=join('.',@pwhere); + $$trolecode=$$role.'.'.$$where; + ($$tstart,$$tend)=split(/\./,$env{$rolekey}); + $$tstatus='is'; + if ($$tstart && $$tstart>$then) { + $$tstatus='future'; + if ($$tstart<$now) { + if ($$tstart && $$tstart>$refresh) { + if (($$where ne '') && ($$role ne '')) { + my (%allroles,%allgroups,$group_privs); + my %userroles = ( + 'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend + ); + my $spec=$$role.'.'.$$where; + my ($tdummy,$tdomain,$trest)=split(/\//,$$where); + if ($$role =~ /^cr\//) { + &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); + } elsif ($$role eq 'gr') { + my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, + $env{'user.name'}); + my $trole = split('_',$rolehash{$$where.'_'.$$role},1); + (undef,my $group_privs) = split(/\//,$trole); + $group_privs = &unescape($group_privs); + &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); + } else { + &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); + } + my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups); + &appenv(\%userroles,[$$role,'cm']); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + } + } + $$tstatus = 'is'; + } + } + if ($$tend) { + if ($$tend<$then) { + $$tstatus='expired'; + } elsif ($$tend<$now) { + $$tstatus='will_not'; + } + } + } + } +} + +sub check_adhoc_privs { + my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_; + my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; + if ($env{$cckey}) { + my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); + &role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); + unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { + &set_adhoc_privileges($cdom,$cnum,$checkrole); + } + } else { + &set_adhoc_privileges($cdom,$cnum,$checkrole); + } +} + +sub set_adhoc_privileges { +# role can be cc or ca + my ($dcdom,$pickedcourse,$role) = @_; + my $area = '/'.$dcdom.'/'.$pickedcourse; + my $spec = $role.'.'.$area; + my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, + $env{'user.name'}); + 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 ".$role); + &appenv( {'request.role' => $spec, + 'request.role.domain' => $dcdom, + 'request.course.sec' => '' + } + ); + my $tadv=0; + if (&allowed('adv') eq 'F') { $tadv=1; } + &appenv({'request.role.adv' => $tadv}); +} + # --------------------------------------------------------------- get interface sub get { @@ -3842,11 +4199,11 @@ sub del { foreach my $item (@$storearr) { $items.=&escape($item).'&'; } + $items=~s/\&$//; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); - return &reply("del:$udomain:$uname:$namespace:$items",$uhome); } @@ -4267,7 +4624,7 @@ sub get_portfolio_access { my (%allgroups,%allroles); my ($start,$end,$role,$sec,$group); foreach my $envkey (%env) { - if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { + if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { my $cid = $2.'_'.$3; if ($1 eq 'gr') { $group = $4; @@ -4407,13 +4764,24 @@ sub is_portfolio_file { } sub usertools_access { - my ($uname,$udom,$tool,$action) = @_; - my $access; - my %tools = ( - aboutme => 1, - blog => 1, - portfolio => 1, - ); + my ($uname,$udom,$tool,$action,$context) = @_; + my ($access,%tools); + if ($context eq '') { + $context = 'tools'; + } + if ($context eq 'requestcourses') { + %tools = ( + official => 1, + unofficial => 1, + community => 1, + ); + } else { + %tools = ( + aboutme => 1, + blog => 1, + portfolio => 1, + ); + } return if (!defined($tools{$tool})); if ((!defined($udom)) || (!defined($uname))) { @@ -4423,18 +4791,23 @@ sub usertools_access { if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { if ($action ne 'reload') { - return $env{'environment.availabletools.'.$tool}; - } + if ($context eq 'requestcourses') { + return $env{'environment.canrequest.'.$tool}; + } else { + return $env{'environment.availabletools.'.$tool}; + } + } } my ($toolstatus,$inststatus); - if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { - $toolstatus = $env{'environment.tools.'.$tool}; + if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && + ($action ne 'reload')) { + $toolstatus = $env{'environment.'.$context.'.'.$tool}; $inststatus = $env{'environment.inststatus'}; } else { - my %userenv = &userenvironment($udom,$uname,'tools.'.$tool); - $toolstatus = $userenv{'tools.'.$tool}; + my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); + $toolstatus = $userenv{$context.'.'.$tool}; $inststatus = $userenv{'inststatus'}; } @@ -4490,11 +4863,36 @@ sub usertools_access { } } } else { - $access = 1; + if ($context eq 'tools') { + $access = 1; + } else { + $access = 0; + } return $access; } } +sub is_course_owner { + my ($cdom,$cnum,$udom,$uname) = @_; + if (($udom eq '') || ($uname eq '')) { + $udom = $env{'user.domain'}; + $uname = $env{'user.name'}; + } + unless (($udom eq '') || ($uname eq '')) { + if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'})) { + if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) { + return 1; + } else { + my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum); + if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) { + return 1; + } + } + } + } + return; +} + sub is_advanced_user { my ($udom,$uname) = @_; my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); @@ -4530,6 +4928,55 @@ sub is_advanced_user { return $is_adv; } +sub check_can_request { + my ($dom,$can_request,$request_domains) = @_; + my $canreq = 0; + my ($types,$typename) = &Apache::loncommon::course_types(); + my @options = ('approval','validate','autolimit'); + my $optregex = join('|',@options); + if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { + foreach my $type (@{$types}) { + if (&usertools_access($env{'user.name'}, + $env{'user.domain'}, + $type,undef,'requestcourses')) { + $canreq ++; + if (ref($request_domains) eq 'HASH') { + push(@{$request_domains->{$type}},$env{'user.domain'}); + } + if ($dom eq $env{'user.domain'}) { + $can_request->{$type} = 1; + } + } + if ($env{'environment.reqcrsotherdom.'.$type} ne '') { + my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type}); + if (@curr > 0) { + foreach my $item (@curr) { + if (ref($request_domains) eq 'HASH') { + my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/); + if ($otherdom ne '') { + if (ref($request_domains->{$type}) eq 'ARRAY') { + unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) { + push(@{$request_domains->{$type}},$otherdom); + } + } else { + push(@{$request_domains->{$type}},$otherdom); + } + } + } + } + unless($dom eq $env{'user.domain'}) { + $canreq ++; + if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) { + $can_request->{$type} = 1; + } + } + } + } + } + } + return $canreq; +} + # ---------------------------------------------- Custom access rule evaluation sub customaccess { @@ -4684,17 +5131,68 @@ sub allowed { my $statecond=0; my $courseprivid=''; + my $ownaccess; + # Community Coordinator or Assistant Co-author browsing resource space. + if (($priv eq 'bro') && ($env{'user.author'})) { + if ($uri eq '') { + $ownaccess = 1; + } else { + if (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { + my $udom = $env{'user.domain'}; + my $uname = $env{'user.name'}; + if ($uri =~ m{^\Q$udom\E/?$}) { + $ownaccess = 1; + } elsif ($uri =~ m{^\Q$udom\E/\Q$uname\E/?}) { + unless ($uri =~ m{\.\./}) { + $ownaccess = 1; + } + } elsif (($udom ne 'public') && ($uname ne 'public')) { + my $now = time; + if ($uri =~ m{^([^/]+)/?$}) { + my $adom = $1; + foreach my $key (keys(%env)) { + if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) { + my ($start,$end) = split('.',$env{$key}); + if (($now >= $start) && (!$end || $end < $now)) { + $ownaccess = 1; + last; + } + } + } + } elsif ($uri =~ m{^([^/]+)/([^/]+)/?}) { + my $adom = $1; + my $aname = $2; + foreach my $role ('ca','aa') { + if ($env{"user.role.$role./$adom/$aname"}) { + my ($start,$end) = + split('.',$env{"user.role.$role./$adom/$aname"}); + if (($now >= $start) && (!$end || $end < $now)) { + $ownaccess = 1; + last; + } + } + } + } + } + } + } + } + # Course if ($env{'user.priv.'.$env{'request.role'}.'./'}=~/\Q$priv\E\&([^\:]*)/) { - $thisallowed.=$1; + unless (($priv eq 'bro') && (!$ownaccess)) { + $thisallowed.=$1; + } } # Domain if ($env{'user.priv.'.$env{'request.role'}.'./'.(split(/\//,$uri))[0].'/'} =~/\Q$priv\E\&([^\:]*)/) { - $thisallowed.=$1; + unless (($priv eq 'bro') && (!$ownaccess)) { + $thisallowed.=$1; + } } # Course: uri itself is a course @@ -4704,7 +5202,9 @@ sub allowed { if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri} =~/\Q$priv\E\&([^\:]*)/) { - $thisallowed.=$1; + unless (($priv eq 'bro') && (!$ownaccess)) { + $thisallowed.=$1; + } } # URI is an uploaded document for this course, default permissions don't matter @@ -4844,7 +5344,7 @@ sub allowed { my $envkey; if ($thisallowed=~/L/) { - foreach $envkey (keys %env) { + foreach $envkey (keys(%env)) { if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { my $courseid=$2; my $roleid=$1.'.'.$2; @@ -5135,7 +5635,7 @@ sub fetch_enrollment_query { } my $host=&hostname($homeserver); my $cmd = ''; - foreach my $affiliate (keys %{$affiliatesref}) { + foreach my $affiliate (keys(%{$affiliatesref})) { $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%'; } $cmd =~ s/%%$//; @@ -5268,11 +5768,21 @@ sub auto_run { sub auto_get_sections { my ($cnum,$cdom,$inst_coursecode) = @_; - my $homeserver = &homeserver($cnum,$cdom); - my @secs = (); - my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); - unless ($response eq 'refused') { - @secs = split(/:/,$response); + my $homeserver; + if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { + $homeserver = &homeserver($cnum,$cdom); + } + if (!defined($homeserver)) { + if ($cdom =~ /^$match_domain$/) { + $homeserver = &domain($cdom,'primary'); + } + } + my @secs; + if (defined($homeserver)) { + my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver)); + unless ($response eq 'refused') { + @secs = split(/:/,$response); + } } return @secs; } @@ -5291,6 +5801,23 @@ sub auto_validate_courseID { return $response; } +sub auto_validate_instcode { + my ($cnum,$cdom,$instcode,$owner) = @_; + my ($homeserver,$response); + if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { + $homeserver = &homeserver($cnum,$cdom); + } + if (!defined($homeserver)) { + if ($cdom =~ /^$match_domain$/) { + $homeserver = &domain($cdom,'primary'); + } + } + my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. + &escape($instcode).':'.&escape($owner),$homeserver)); + my ($outcome,$description) = map { &unescape($_); } split('&',$response,2); + return ($outcome,$description); +} + sub auto_create_password { my ($cnum,$cdom,$authparam,$udom) = @_; my ($homeserver,$response); @@ -5405,6 +5932,13 @@ sub auto_instcode_format { push(@homeservers,$tryserver); } } + } elsif ($caller eq 'requests') { + if ($codedom =~ /^$match_domain$/) { + my $chome = &domain($codedom,'primary'); + unless ($chome eq 'no_host') { + push(@homeservers,$chome); + } + } } else { push(@homeservers,&homeserver($caller,$codedom)); } @@ -5462,7 +5996,81 @@ sub auto_instcode_defaults { } return $response; -} +} + +sub auto_possible_instcodes { + my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_; + unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && + (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { + return; + } + my (@homeservers,$uhome); + if (defined(&domain($domain,'primary'))) { + $uhome=&domain($domain,'primary'); + push(@homeservers,&domain($domain,'primary')); + } else { + my %servers = &get_servers($domain,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } + } + } + my $response; + foreach my $server (@homeservers) { + $response=&reply('autopossibleinstcodes:'.$domain,$server); + next if ($response =~ /(con_lost|error|no_such_host|refused)/); + my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = + split(':',$response); + @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr)); + @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr)); + foreach my $item (split('&',$cat_title)) { + my ($name,$value)=split('=',$item); + $cat_titles->{&unescape($name)}=&thaw_unescape($value); + } + foreach my $item (split('&',$cat_order)) { + my ($name,$value)=split('=',$item); + $cat_orders->{&unescape($name)}=&thaw_unescape($value); + } + return 'ok'; + } + return $response; +} + +sub auto_courserequest_checks { + my ($dom) = @_; + my ($homeserver,%validations); + if ($dom =~ /^$match_domain$/) { + $homeserver = &domain($dom,'primary'); + } + unless ($homeserver eq 'no_host') { + my $response=&reply('autocrsreqchecks:'.$dom,$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_courserequest_validation { + my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_; + my ($homeserver,$response); + if ($dom =~ /^$match_domain$/) { + $homeserver = &domain($dom,'primary'); + } + unless ($homeserver eq 'no_host') { + + $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner). + ':'.&escape($crstype).':'.&escape($inststatuslist). + ':'.&escape($instcode).':'.&escape($instseclist), + $homeserver)); + } + return $response; +} sub auto_validate_class_sec { my ($cdom,$cnum,$owners,$inst_class) = @_; @@ -5615,28 +6223,38 @@ sub devalidate_getgroups_cache { # ------------------------------------------------------------------ Plain Text sub plaintext { - my ($short,$type,$cid) = @_; - if ($short =~ /^cr/) { + my ($short,$type,$cid,$forcedefault) = @_; + if ($short =~ m{^cr/}) { return (split('/',$short))[-1]; } if (!defined($cid)) { $cid = $env{'request.course.id'}; } - if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) { - return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short. - '.plaintext'}); - } my %rolenames = ( - Course => 'std', - Group => 'alt1', + Course => 'std', + Community => 'alt1', ); - if (defined($type) && - defined($rolenames{$type}) && - defined($prp{$short}{$rolenames{$type}})) { + if ($cid ne '') { + if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') { + unless ($forcedefault) { + my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; + &Apache::lonlocal::mt_escape(\$roletext); + return &Apache::lonlocal::mt($roletext); + } + } + } + if ((defined($type)) && (defined($rolenames{$type})) && + (defined($rolenames{$type})) && + (defined($prp{$short}{$rolenames{$type}}))) { return &Apache::lonlocal::mt($prp{$short}{$rolenames{$type}}); - } else { - return &Apache::lonlocal::mt($prp{$short}{'std'}); + } elsif ($cid ne '') { + my $crstype = $env{'course.'.$cid.'.type'}; + if (($crstype ne '') && (defined($rolenames{$crstype})) && + (defined($prp{$short}{$rolenames{$crstype}}))) { + return &Apache::lonlocal::mt($prp{$short}{$rolenames{$crstype}}); + } } + return &Apache::lonlocal::mt($prp{$short}{'std'}); } # ----------------------------------------------------------------- Assign Role @@ -5649,10 +6267,27 @@ sub assignrole { my $cwosec=$url; $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; unless (&allowed('ccr',$cwosec)) { - &logthis('Refused custom assignrole: '. - $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '. - $env{'user.name'}.' at '.$env{'user.domain'}); - return 'refused'; + my $refused = 1; + if ($context eq 'requestcourses') { + if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { + if ($role =~ m{^cr/($match_domain)/($match_username)/([^/]+)$}) { + if (($1 eq $env{'user.domain'}) && ($2 eq $env{'user.name'})) { + my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); + my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); + if ($crsenv{'internal.courseowner'} eq + $env{'user.name'}.':'.$env{'user.domain'}) { + $refused = ''; + } + } + } + } + } + if ($refused) { + &logthis('Refused custom assignrole: '. + $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start. + ' by '.$env{'user.name'}.' at '.$env{'user.domain'}); + return 'refused'; + } } $mrole='cr'; } elsif ($role =~ /^gr\//) { @@ -5678,9 +6313,48 @@ sub assignrole { $refused = 1; } if ($refused) { - if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); + if (!$selfenroll && $context eq 'course') { + my %crsenv; + if ($role eq 'cc' || $role eq 'co') { + %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); + if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) { + if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) { + if ($crsenv{'internal.courseowner'} eq + $env{'user.name'}.':'.$env{'user.domain'}) { + $refused = ''; + } + } + } elsif (($role eq 'co') && ($cnum =~ /^$match_community$/)) { + if ($env{'request.role'} eq 'co./'.$cdom.'/'.$cnum) { + if ($crsenv{'internal.courseowner'} eq + $env{'user.name'}.':'.$env{'user.domain'}) { + $refused = ''; + } + } + } + } + } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { $refused = ''; - } else { + } elsif ($context eq 'requestcourses') { + my @possroles = ('st','ta','ep','in','cc','co'); + if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { + my $wrongcc; + if ($cnum =~ /^$match_community$/) { + $wrongcc = 1 if ($role eq 'cc'); + } else { + $wrongcc = 1 if ($role eq 'co'); + } + unless ($wrongcc) { + my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); + if ($crsenv{'internal.courseowner'} eq + $env{'user.name'}.':'.$env{'user.domain'}) { + $refused = ''; + } + } + } + } + if ($refused) { &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. ' '.$role.' '.$end.' '.$start.' by '. $env{'user.name'}.' at '.$env{'user.domain'}); @@ -5727,10 +6401,97 @@ sub assignrole { &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, $origstart,$selfenroll,$context); } + if ($role eq 'cc') { + &autoupdate_coowners($url,$end,$start,$uname,$udom); + } } return $answer; } +sub autoupdate_coowners { + my ($url,$end,$start,$uname,$udom) = @_; + my ($cdom,$cnum) = ($url =~ m{^/($match_domain)/($match_courseid)}); + if (($cdom ne '') && ($cnum ne '')) { + my $now = time; + my %domdesign = &Apache::loncommon::get_domainconf($cdom); + if ($domdesign{$cdom.'.autoassign.co-owners'}) { + my %coursehash = &coursedescription($cdom.'_'.$cnum); + my $instcode = $coursehash{'internal.coursecode'}; + if ($instcode ne '') { + if (($start && $start <= $now) && ($end == 0) || ($end > $now)) { + unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) { + my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners); + my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom); + if ($result eq 'valid') { + if ($coursehash{'internal.co-owners'}) { + foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { + push(@newcoowners,$coowner); + } + unless (grep(/^\Q$uname\E:\Q$udom\E$/,@newcoowners)) { + push(@newcoowners,$uname.':'.$udom); + } + @newcoowners = sort(@newcoowners); + } else { + push(@newcoowners,$uname.':'.$udom); + } + } else { + if ($coursehash{'internal.co-owners'}) { + foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { + unless ($coowner eq $uname.':'.$udom) { + push(@newcoowners,$coowner); + } + } + unless (@newcoowners > 0) { + $delcoowners = 1; + $coowners = ''; + } + } + } + if (@newcoowners || $delcoowners) { + &store_coowners($cdom,$cnum,$coursehash{'home'}, + $delcoowners,@newcoowners); + } + } + } + } + } + } +} + +sub store_coowners { + my ($cdom,$cnum,$chome,$delcoowners,@newcoowners) = @_; + my $cid = $cdom.'_'.$cnum; + my ($coowners,$delresult,$putresult); + if (@newcoowners) { + $coowners = join(',',@newcoowners); + my %coownershash = ( + 'internal.co-owners' => $coowners, + ); + $putresult = &put('environment',\%coownershash,$cdom,$cnum); + if ($putresult eq 'ok') { + if ($env{'course.'.$cid.'.num'} eq $cnum) { + &appenv({'course.'.$cid.'.internal.co-owners' => $coowners}); + } + } + } + if ($delcoowners) { + $delresult = &Apache::lonnet::del('environment',['internal.co-owners'],$cdom,$cnum); + if ($delresult eq 'ok') { + if ($env{'course.'.$cid.'.internal.co-owners'}) { + &Apache::lonnet::delenv('course.'.$cid.'.internal.co-owners'); + } + } + } + if (($putresult eq 'ok') || ($delresult eq 'ok')) { + my %crsinfo = + &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); + if (ref($crsinfo{$cid}) eq 'HASH') { + $crsinfo{$cid}{'co-owners'} = \@newcoowners; + my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime'); + } + } +} + # -------------------------------------------------- Modify user authentication # Overrides without validation @@ -5763,12 +6524,18 @@ sub modifyuser { my ($udom, $uname, $uid, $umode, $upass, $first, $middle, $last, $gene, - $forceid, $desiredhome, $email, $inststatus)=@_; + $forceid, $desiredhome, $email, $inststatus, $candelete)=@_; $udom= &LONCAPA::clean_domain($udom); $uname=&LONCAPA::clean_username($uname); + my $showcandelete = 'none'; + if (ref($candelete) eq 'ARRAY') { + if (@{$candelete} > 0) { + $showcandelete = join(', ',@{$candelete}); + } + } &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. $umode.', '.$first.', '.$middle.', '. - $last.', '.$gene.'(forceid: '.$forceid.')'. + $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. (defined($desiredhome) ? ' desiredhome = '.$desiredhome : ' desiredhome not specified'). ' by '.$env{'user.name'}.' at '.$env{'user.domain'}. @@ -5833,9 +6600,33 @@ sub modifyuser { %names = @tmp; } # -# Make sure to not trash student environment if instructor does not bother -# to supply name and email information -# +# If name, email and/or uid are blank (e.g., because an uploaded file +# of users did not contain them), do not overwrite existing values +# unless field is in $candelete array ref. +# + my @fields = ('firstname','middlename','lastname','generation', + 'permanentemail','id'); + my %newvalues; + if (ref($candelete) eq 'ARRAY') { + foreach my $field (@fields) { + if (grep(/^\Q$field\E$/,@{$candelete})) { + if ($field eq 'firstname') { + $names{$field} = $first; + } elsif ($field eq 'middlename') { + $names{$field} = $middle; + } elsif ($field eq 'lastname') { + $names{$field} = $last; + } elsif ($field eq 'generation') { + $names{$field} = $gene; + } elsif ($field eq 'permanentemail') { + $names{$field} = $email; + } elsif ($field eq 'id') { + $names{$field} = $uid; + } + } + } + } + if ($first) { $names{'firstname'} = $first; } if (defined($middle)) { $names{'middlename'} = $middle; } if ($last) { $names{'lastname'} = $last; } @@ -5845,7 +6636,21 @@ sub modifyuser { if ($email=~/\@/) { $names{'permanentemail'} = $email; } } if ($uid) { $names{'id'} = $uid; } - if (defined($inststatus)) { $names{'inststatus'} = $inststatus; } + if (defined($inststatus)) { + $names{'inststatus'} = ''; + my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom); + if (ref($usertypes) eq 'HASH') { + my @okstatuses; + foreach my $item (split(/:/,$inststatus)) { + if (defined($usertypes->{$item})) { + push(@okstatuses,$item); + } + } + if (@okstatuses) { + $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses); + } + } + } my $reply = &put('environment', \%names, $udom,$uname); if ($reply ne 'ok') { return 'error: '.$reply; } my $sqlresult = &update_allusers_table($uname,$udom,\%names); @@ -5867,7 +6672,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)=@_; + $selfenroll,$context,$inststatus)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -5876,7 +6681,7 @@ sub modifystudent { # --------------------------------------------------------------- Make the user my $reply=&modifyuser ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid, - $desiredhome,$email); + $desiredhome,$email,$inststatus); unless ($reply eq 'ok') { return $reply; } # This will cause &modify_student_enrollment to get the uid from the # students environment @@ -5990,48 +6795,90 @@ sub writecoursepref { sub createcourse { my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, - $course_owner,$crstype)=@_; + $course_owner,$crstype,$cnum,$context,$category)=@_; $url=&declutter($url); my $cid=''; - unless (&allowed('ccc',$udom)) { + if ($context eq 'requestcourses') { + my $can_create = 0; + my ($ownername,$ownerdom) = split(':',$course_owner); + if ($udom eq $ownerdom) { + if (&usertools_access($ownername,$ownerdom,$category,undef, + $context)) { + $can_create = 1; + } + } else { + my %userenv = &userenvironment($ownerdom,$ownername,'reqcrsotherdom.'. + $category); + if ($userenv{'reqcrsotherdom.'.$category} ne '') { + my @curr = split(',',$userenv{'reqcrsotherdom.'.$category}); + if (@curr > 0) { + my @options = qw(approval validate autolimit); + my $optregex = join('|',@options); + if (grep(/^\Q$udom\E:($optregex)(=?\d*)$/,@curr)) { + $can_create = 1; + } + } + } + } + if ($can_create) { + unless ($ownername eq $env{'user.name'} && $ownerdom eq $env{'user.domain'}) { + unless (&allowed('ccc',$udom)) { + return 'refused'; + } + } + } else { + return 'refused'; + } + } elsif (!&allowed('ccc',$udom)) { return 'refused'; } -# ------------------------------------------------------------------- Create ID - my $uname=int(1+rand(9)). - ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. - substr($$.time,0,5).unpack("H8",pack("I32",time)). - unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; -# ----------------------------------------------- Make sure that does not exist - my $uhome=&homeserver($uname,$udom,'true'); - unless (($uhome eq '') || ($uhome eq 'no_host')) { - $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)). - unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; - $uhome=&homeserver($uname,$udom,'true'); - unless (($uhome eq '') || ($uhome eq 'no_host')) { - return 'error: unable to generate unique course-ID'; - } - } -# ------------------------------------------------ Check supplied server name - $course_server = $env{'user.homeserver'} if (! defined($course_server)); - if (! &is_library($course_server)) { - return 'error:bad server name '.$course_server; +# --------------------------------------------------------------- Get Unique ID + my $uname; + if ($cnum =~ /^$match_courseid$/) { + my $chome=&homeserver($cnum,$udom,'true'); + if (($chome eq '') || ($chome eq 'no_host')) { + $uname = $cnum; + } else { + $uname = &generate_coursenum($udom,$crstype); + } + } else { + $uname = &generate_coursenum($udom,$crstype); + } + return $uname if ($uname =~ /^error/); +# -------------------------------------------------- Check supplied server name + if (!defined($course_server)) { + if (defined(&domain($udom,'primary'))) { + $course_server = &domain($udom,'primary'); + } else { + $course_server = $env{'user.home'}; + } + } + my %host_servers = + &Apache::lonnet::get_servers($udom,'library'); + unless ($host_servers{$course_server}) { + return 'error: invalid home server for course: '.$course_server; } # ------------------------------------------------------------- Make the course my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::', $course_server); unless ($reply eq 'ok') { return 'error: '.$reply; } - $uhome=&homeserver($uname,$udom,'true'); + my $uhome=&homeserver($uname,$udom,'true'); if (($uhome eq '') || ($uhome eq 'no_host')) { return 'error: no such course'; } # ----------------------------------------------------------------- Course made # log existence + my $now = time; my $newcourse = { $udom.'_'.$uname => { description => $description, inst_code => $inst_code, owner => $course_owner, type => $crstype, + creator => $env{'user.name'}.':'. + $env{'user.domain'}, + created => $now, + context => $context, }, }; &courseidput($udom,$newcourse,$uhome,'notime'); @@ -6056,11 +6903,51 @@ ENDINITMAP } # ----------------------------------------------------------- Write preferences &writecoursepref($udom.'_'.$uname, - ('description' => $description, - 'url' => $topurl)); + ('description' => $description, + 'url' => $topurl, + 'internal.creator' => $env{'user.name'}.':'. + $env{'user.domain'}, + 'internal.created' => $now, + 'internal.creationcontext' => $context) + ); return '/'.$udom.'/'.$uname; } +# ------------------------------------------------------------------- Create ID +sub generate_coursenum { + my ($udom,$crstype) = @_; + my $domdesc = &domain($udom); + return 'error: invalid domain' if ($domdesc eq ''); + my $first; + if ($crstype eq 'Community') { + $first = '0'; + } else { + $first = int(1+rand(9)); + } + my $uname=$first. + ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. + substr($$.time,0,5).unpack("H8",pack("I32",time)). + unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; +# ----------------------------------------------- Make sure that does not exist + my $uhome=&homeserver($uname,$udom,'true'); + unless (($uhome eq '') || ($uhome eq 'no_host')) { + if ($crstype eq 'Community') { + $first = '0'; + } else { + $first = int(1+rand(9)); + } + $uname=$first. + ('a'..'z','A'..'Z','0'..'9')[int(rand(62))]. + substr($$.time,0,5).unpack("H8",pack("I32",time)). + unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'}; + $uhome=&homeserver($uname,$udom,'true'); + unless (($uhome eq '') || ($uhome eq 'no_host')) { + return 'error: unable to generate unique course-ID'; + } + } + return $uname; +} + sub is_course { my ($cdom,$cnum) = @_; my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef, @@ -6071,6 +6958,39 @@ sub is_course { return 0; } +sub store_userdata { + my ($storehash,$datakey,$namespace,$udom,$uname) = @_; + my $result; + if ($datakey ne '') { + if (ref($storehash) eq 'HASH') { + if ($udom eq '' || $uname eq '') { + $udom = $env{'user.domain'}; + $uname = $env{'user.name'}; + } + my $uhome=&homeserver($uname,$udom); + if (($uhome eq '') || ($uhome eq 'no_host')) { + $result = 'error: no_host'; + } else { + $storehash->{'ip'} = $ENV{'REMOTE_ADDR'}; + $storehash->{'host'} = $perlvar{'lonHostID'}; + + my $namevalue=''; + foreach my $key (keys(%{$storehash})) { + $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; + } + $namevalue=~s/\&$//; + $result = &reply("store:$env{'user.domain'}:$env{'user.name'}:". + "$namespace:$datakey:$namevalue",$uhome); + } + } else { + $result = 'error: data to store was not a hash reference'; + } + } else { + $result= 'error: invalid requestkey'; + } + return $result; +} + # ---------------------------------------------------------- Assign Custom Role sub assigncustomrole { @@ -7560,6 +8480,11 @@ sub devalidate_title_cache { &devalidate_cache_new('title',$key); } +# ------------------------------------------------- Get the title of a course + +sub current_course_title { + return $env{ 'course.' . $env{'request.course.id'} . '.description' }; +} # ------------------------------------------------- Get the title of a resource sub gettitle { @@ -7626,7 +8551,7 @@ sub symblist { if (($env{'request.course.fn'}) && (%newhash)) { if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', &GDBM_WRCREAT(),0640)) { - foreach my $url (keys %newhash) { + foreach my $url (keys(%newhash)) { next if ($url eq 'last_known' && $env{'form.no_update_last_known'}); $hash{declutter($url)}=&encode_symb($mapname, @@ -7663,6 +8588,9 @@ sub symbverify { if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { + if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { + $thisurl =~ s/\?.+$//; + } my $ids=$bighash{'ids_'.&clutter($thisurl)}; unless ($ids) { $ids=$bighash{'ids_/'.$thisurl}; @@ -7671,6 +8599,9 @@ sub symbverify { # ------------------------------------------------------------------- Has ID(s) foreach my $id (split(/\,/,$ids)) { my ($mapid,$resid)=split(/\./,$id); + if ($thisfn =~ m{^/adm/wrapper/ext/}) { + $symb =~ s/\?.+$//; + } if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) eq $symb) { @@ -8547,7 +9478,9 @@ sub declutter { $thisfn=~s|^adm/wrapper/||; $thisfn=~s|^adm/coursedocs/showdoc/||; $thisfn=~s/^res\///; - $thisfn=~s/\?.+$//; + unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) { + $thisfn=~s/\?.+$//; + } return $thisfn; } @@ -8559,8 +9492,8 @@ sub clutter { || $thisfn =~ m{^/adm/(includes|pages)} ) { $thisfn='/res'.$thisfn; } - if ($thisfn !~m|/adm|) { - if ($thisfn =~ m|/ext/|) { + if ($thisfn !~m|^/adm|) { + if ($thisfn =~ m|^/ext/|) { $thisfn='/adm/wrapper'.$thisfn; } else { my ($ext) = ($thisfn =~ /\.(\w+)$/); @@ -8964,6 +9897,31 @@ sub get_dns { return %iphost; } + + # + # Given a DNS returns the loncapa host name for that DNS + # + sub host_from_dns { + my ($dns) = @_; + my @hosts; + my $ip; + + if (exists($name_to_ip{$dns})) { + $ip = $name_to_ip{$dns}; + } + if (!$ip) { + $ip = gethostbyname($dns); # Initial translation to IP is in net order. + if (length($ip) == 4) { + $ip = &IO::Socket::inet_ntoa($ip); + } + } + if ($ip) { + @hosts = get_hosts_from_ip($ip); + return $hosts[0]; + } + return undef; + } + } BEGIN { @@ -9245,9 +10203,11 @@ in the user's environment.db and in %env =item * X -B: removes all items from the session -environment file that matches the regular expression in $regexp. The -values are also delted from the current processes %env. +B: removes all items from the session +environment file that begin with $delthis. If the +optional second arg - $regexp - is true, $delthis is treated as a +regular expression, otherwise \Q$delthis\E is used. +The values are also deleted from the current processes %env. =item * get_env_multiple($name) @@ -9344,9 +10304,14 @@ and course level =item * -plaintext($short) : return value in %prp hash (rolesplain.tab); plain text -explanation of a user role term - +plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash +(rolesplain.tab); plain text explanation of a user role term. +$type is Course (default) or Community. +If $forcedefault evaluates to true, text returned will be default +text for $type. Otherwise, if this is a course, the text returned +will be a custom name for the role (if defined in the course's +environment). If no custom name is defined the default is returned. + =item * get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) : @@ -9388,9 +10353,16 @@ modifyuserauth($udom,$uname,$umode,$upas =item * -modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene, - $forceid,$desiredhome,$email,$inststatus) : -modify user +modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last, $gene, + $forceid,$desiredhome,$email,$inststatus,$candelete) : + +will update user information (firstname,middlename,lastname,generation, +permanentemail), and if forceid is true, student/employee ID also. +A user's institutional affiliation(s) can also be updated. +User information fields will not be overwritten with empty entries +unless the field is included in the $candelete array reference. +This array is included when a single user is modified via "Manage Users", +or when Autoupdate.pl is run by cron in a domain. =item * @@ -9551,7 +10523,11 @@ database) for a course =item * -createcourse($udom,$description,$url) : make/modify course +createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course + +=item * + +generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community). =back @@ -9855,8 +10831,15 @@ dirlist($uri) : return directory list ba spareserver() : find server with least workload from spare.tab + +=item * + +host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef +if there is no corresponding loncapa host. + =back + =head2 Apache Request =over 4 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.