--- loncom/interface/loncommon.pm 2021/01/04 17:29:30 1.1075.2.141.2.12 +++ loncom/interface/loncommon.pm 2017/03/21 23:19:29 1.1278 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.141.2.12 2021/01/04 17:29:30 raeburn Exp $ +# $Id: loncommon.pm,v 1.1278 2017/03/21 23:19:29 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,20 +71,18 @@ use Apache::lonuserutils(); use Apache::lonuserstate(); use Apache::courseclassifier(); use LONCAPA qw(:DEFAULT :match); -use HTTP::Request; use DateTime::TimeZone; use DateTime::Locale; use Encode(); +use Text::Aspell; use Authen::Captcha; use Captcha::reCAPTCHA; use JSON::DWIW; use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version -use File::Copy(); -use File::Path(); -use String::CRC32(); -use Short::URL(); +use MIME::Lite; +use MIME::Types; # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -169,6 +167,7 @@ sub ssi_with_retries { # ----------------------------------------------- Filetypes/Languages/Copyright my %language; my %supported_language; +my %supported_codes; my %latex_language; # For choosing hyphenation in my %latex_language_bykey; # for choosing hyphenation from metadata my %cprtag; @@ -199,18 +198,19 @@ BEGIN { { my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/language.tab'; - if ( open(my $fh,'<',$langtabfile) ) { + if ( open(my $fh,"<$langtabfile") ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); - my ($key,$two,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line)); + my ($key,$code,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line)); $language{$key}=$val.' - '.$enc; if ($sup) { $supported_language{$key}=$sup; + $supported_codes{$key} = $code; } if ($latex) { $latex_language_bykey{$key} = $latex; - $latex_language{$two} = $latex; + $latex_language{$code} = $latex; } } close($fh); @@ -220,7 +220,7 @@ BEGIN { { my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/copyright.tab'; - if ( open (my $fh,'<',$copyrightfile) ) { + if ( open (my $fh,"<$copyrightfile") ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -234,7 +234,7 @@ BEGIN { { my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/source_copyright.tab'; - if ( open (my $fh,'<',$sourcecopyrightfile) ) { + if ( open (my $fh,"<$sourcecopyrightfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -248,7 +248,7 @@ BEGIN { # -------------------------------------------------------------- default domain designs my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/default.tab'; - if ( open (my $fh,'<',$designfile) ) { + if ( open (my $fh,"<$designfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -262,7 +262,7 @@ BEGIN { { my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filecategories.tab'; - if ( open (my $fh,'<',$categoryfile) ) { + if ( open (my $fh,"<$categoryfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -277,7 +277,7 @@ BEGIN { { my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filetypes.tab'; - if ( open (my $fh,'<',$typesfile) ) { + if ( open (my $fh,"<$typesfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -430,7 +430,7 @@ sub studentbrowser_javascript { block @@ -1074,6 +1094,9 @@ linked_select_forms takes the following =item * $onchangesecond, additional javascript call to execute for an onchange event for the second \n"; + $result .= ""; } +sub crsauthor_url { + my ($url) = @_; + if ($url eq '') { + $url = $ENV{'REQUEST_URI'}; + } + my ($cnum,$cdom); + if ($env{'request.course.id'}) { + my ($audom,$auname) = ($url =~ m{^/priv/($match_domain)/($match_name)/}); + if ($audom ne '' && $auname ne '') { + if (($env{'course.'.$env{'request.course.id'}.'.num'} eq $auname) && + ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $audom)) { + $cnum = $auname; + $cdom = $audom; + } + } + } + return ($cnum,$cdom); +} + +sub import_crsauthor_form { + my ($form,$firstselectname,$secondselectname,$onchangefirst,$only,$suffix,$disabled) = @_; + return (0) unless ($env{'request.course.id'}); + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $crshome = $env{'course.'.$env{'request.course.id'}.'.home'}; + return (0) unless (($cnum ne '') && ($cdom ne '')); + my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'}; + my @ids=&Apache::lonnet::current_machine_ids(); + my ($output,$is_home,$relpath,%subdirs,%files,%selimport_menus); + + if (grep(/^\Q$crshome\E$/,@ids)) { + $is_home = 1; + } + $relpath = "/priv/$cdom/$cnum"; + &Apache::lonnet::recursedirs($is_home,'priv',$londocroot,$relpath,'',\%subdirs,\%files); + my %lt = &Apache::lonlocal::texthash ( + fnam => 'Filename', + dire => 'Directory', + ); + my $numdirs = scalar(keys(%files)); + my (%possexts,$singledir,@singledirfiles); + if ($only) { + map { $possexts{$_} = 1; } split(/\s*,\s*/,$only); + } + my (%nonemptydirs,$possdirs); + if ($numdirs > 1) { + my @order; + foreach my $key (sort { lc($a) cmp lc($b) } (keys(%files))) { + if (ref($files{$key}) eq 'HASH') { + my $shown = $key; + if ($key eq '') { + $shown = '/'; + } + my @ordered = (); + foreach my $file (sort { lc($a) cmp lc($b) } (keys(%{$files{$key}}))) { + if ($only) { + my ($ext) = ($file =~ /\.([^.]+)$/); + unless ($possexts{lc($ext)}) { + next; + } + } + $selimport_menus{$key}->{'select2'}->{$file} = $file; + push(@ordered,$file); + } + if (@ordered) { + push(@order,$key); + $nonemptydirs{$key} = 1; + $selimport_menus{$key}->{'text'} = $shown; + $selimport_menus{$key}->{'default'} = ''; + $selimport_menus{$key}->{'select2'}->{''} = ''; + $selimport_menus{$key}->{'order'} = \@ordered; + } + } + } + $possdirs = scalar(keys(%nonemptydirs)); + if ($possdirs > 1) { + my @order = sort { lc($a) cmp lc($b) } (keys(%nonemptydirs)); + $output = $lt{'dire'}. + &linked_select_forms($form,'
'. + $lt{'fnam'},'', + $firstselectname,$secondselectname, + \%selimport_menus,\@order, + $onchangefirst,'',$suffix).'
'; + } elsif ($possdirs == 1) { + $singledir = (keys(%nonemptydirs))[0]; + if (ref($selimport_menus{$singledir}->{'order'}) eq 'ARRAY') { + @singledirfiles = @{$selimport_menus{$singledir}->{'order'}}; + } + delete($selimport_menus{$singledir}); + } + } elsif ($numdirs == 1) { + $singledir = (keys(%files))[0]; + foreach my $file (sort { lc($a) cmp lc($b) } (keys(%{$files{$singledir}}))) { + if ($only) { + my ($ext) = ($file =~ /\.([^.]+)$/); + unless ($possexts{lc($ext)}) { + next; + } + } + push(@singledirfiles,$file); + } + if (@singledirfiles) { + $possdirs == 1; + } + } + if (($possdirs == 1) && (@singledirfiles)) { + my $showdir = $singledir; + if ($singledir eq '') { + $showdir = '/'; + } + $output = $lt{'dire'}. + '
'. + $lt{'fnam'}.'
'."\n"; + } + return ($possdirs,$output); +} =pod @@ -2261,7 +2556,7 @@ option_name => displayed text. An option a javascript onchange item, e.g., onchange="this.form.submit();". An optional arg -- $readonly -- if true will cause the select form to be disabled, e.g., for the case where an instructor has a section- -specific role, and is viewing/modifying parameters. +specific role, and is viewing/modifying parameters. See lonrights.pm for an example invocation and use. @@ -2464,7 +2759,7 @@ The optional $incdoms is a reference to The optional $excdoms is a reference to an array of domains which will be excluded from the available options. -The optional $disabled argument, if true, adds the disabled attribute to the select tag. +The optional $disabled argument, if true, adds the disabled attribute to the select tag. =cut @@ -2485,7 +2780,7 @@ sub select_dom_form { } if ($includeempty) { @domains=('',@domains); } if (ref($excdoms) eq 'ARRAY') { - map { $exclude{$_} = 1; } @{$excdoms}; + map { $exclude{$_} = 1; } @{$excdoms}; } my $selectdomain = "{'clonedomain'}.'/'.$args->{'clonecourse'}; my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); - my $clonetitle; - my @clonemsg; + my $clonemsg; my $can_clone = 0; my $lctype = lc($args->{'crstype'}); if ($lctype ne 'community') { @@ -15168,38 +15328,16 @@ sub check_clone { } if ($clonehome eq 'no_host') { if ($args->{'crstype'} eq 'Community') { - push(@clonemsg,({ - mt => 'No new community created.', - args => [], - }, - { - mt => 'A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.', - args => [$args->{'clonedomain'}.':'.$args->{'clonedomain'}], - })); + $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); } else { - push(@clonemsg,({ - mt => 'No new course created.', - args => [], - }, - { - mt => 'A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.', - args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}], - })); - } + $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + } } else { my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); - $clonetitle = $clonedesc{'description'}; if ($args->{'crstype'} eq 'Community') { if ($clonedesc{'type'} ne 'Community') { - push(@clonemsg,({ - mt => 'No new community created.', - args => [], - }, - { - mt => 'A new community could not be cloned from the specified original - [_1] - because it is a course not a community.', - args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}], - })); - return ($can_clone,\@clonemsg,$cloneid,$clonehome); + $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + return ($can_clone, $clonemsg, $cloneid, $clonehome); } } if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && @@ -15216,7 +15354,7 @@ sub check_clone { if ($args->{'ccdomain'} eq $args->{'clonedomain'}) { $can_clone = 1; } - } elsif (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && + } elsif (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && ($args->{'clonedomain'} eq $args->{'course_domain'})) { if (&Apache::lonnet::default_instcode_cloning($args->{'clonedomain'},$domdefs{'canclone'}, $clonehash{'internal.coursecode'},$args->{'crscode'})) { @@ -15235,7 +15373,7 @@ sub check_clone { $can_clone = 1; } unless ($can_clone) { - if (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && + if (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && ($args->{'clonedomain'} eq $args->{'course_domain'})) { my (%gotdomdefaults,%gotcodedefaults); foreach my $cloner (@cloners) { @@ -15274,12 +15412,12 @@ sub check_clone { if ($args->{'crstype'} eq 'Community') { $ccrole = 'co'; } - my %roleshash = - &Apache::lonnet::get_my_roles($args->{'ccuname'}, - $args->{'ccdomain'}, + my %roleshash = + &Apache::lonnet::get_my_roles($args->{'ccuname'}, + $args->{'ccdomain'}, 'userroles',['active'],[$ccrole], - [$args->{'clonedomain'}]); - if ($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) { + [$args->{'clonedomain'}]); + if ($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) { $can_clone = 1; } elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'}, $args->{'ccuname'},$args->{'ccdomain'})) { @@ -15288,34 +15426,20 @@ sub check_clone { } unless ($can_clone) { if ($args->{'crstype'} eq 'Community') { - push(@clonemsg,({ - mt => 'No new community created.', - args => [], - }, - { - mt => 'The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).', - args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}], - })); + $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); } else { - push(@clonemsg,({ - mt => 'No new course created.', - args => [], - }, - { - mt => 'The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).', - args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}], - })); + $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); } } } } - return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle); + return ($can_clone, $clonemsg, $cloneid, $clonehome); } sub construct_course { my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context, - $cnum,$category,$coderef,$callercontext,$user_lh) = @_; - my ($outcome,$msgref,$clonemsgref); + $cnum,$category,$coderef) = @_; + my $outcome; my $linefeed = '
'."\n"; if ($context eq 'auto') { $linefeed = "\n"; @@ -15324,18 +15448,30 @@ sub construct_course { # # Are we cloning? # - my ($can_clone,$cloneid,$clonehome,$clonetitle); + my ($can_clone, $clonemsg, $cloneid, $clonehome); if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { - ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed); + ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed); + if ($context ne 'auto') { + if ($clonemsg ne '') { + $clonemsg = ''.$clonemsg.''; + } + } + $outcome .= $clonemsg.$linefeed; + if (!$can_clone) { - return (0,$outcome,$clonemsgref); + return (0,$outcome); } } # # Open course # - my $crstype = lc($args->{'crstype'}); + my $showncrstype; + if ($args->{'crstype'} eq 'Placement') { + $showncrstype = 'placement test'; + } else { + $showncrstype = lc($args->{'crstype'}); + } my %cenv=(); $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'}, $args->{'cdescr'}, @@ -15346,20 +15482,15 @@ sub construct_course { $args->{'ccuname'}.':'. $args->{'ccdomain'}, $args->{'crstype'}, - $cnum,$context,$category, - $callercontext); + $cnum,$context,$category); # Note: The testing routines depend on this being output; see # Utils::Course. This needs to at least be output as a comment # if anyone ever decides to not show this, and Utils::Course::new # will need to be suitably modified. - if (($callercontext eq 'auto') && ($user_lh ne '')) { - $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; - } else { - $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; - } + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; if ($$courseid =~ /^error:/) { - return (0,$outcome,$clonemsgref); + return (0,$outcome); } # @@ -15368,37 +15499,23 @@ sub construct_course { ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); if ($crsuhome eq 'no_host') { - if (($callercontext eq 'auto') && ($user_lh ne '')) { - $outcome .= &mt_user($user_lh, - 'Course creation failed, unrecognized course home server.'); - } else { - $outcome .= &mt('Course creation failed, unrecognized course home server.'); - } - $outcome .= $linefeed; - return (0,$outcome,$clonemsgref); + $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed; + return (0,$outcome); } $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; # # Do the cloning # - my @clonemsg; if ($can_clone && $cloneid) { - push(@clonemsg, - { - mt => 'Created [_1] by cloning from [_2]', - args => [$crstype,$clonetitle], - }); + $clonemsg = &mt('Cloning [_1] from [_2]',$showncrstype,$clonehome); + if ($context ne 'auto') { + $clonemsg = ''.$clonemsg.''; + } + $outcome .= $clonemsg.$linefeed; my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); # Copy all files - my @info = - &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'}, - $args->{'dateshift'},$args->{'crscode'}, - $args->{'ccuname'}.':'.$args->{'ccdomain'}, - $args->{'tinyurls'}); - if (@info) { - push(@clonemsg,@info); - } + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'}); # Restore URL $cenv{'url'}=$oldcenv{'url'}; # Restore title @@ -15559,7 +15676,7 @@ sub construct_course { $outcome .= $linefeed; } else { $outcome .= "

\n"; - } + } } if ($args->{'no_end_date'}) { $args->{'endaccess'} = 0; @@ -15628,7 +15745,7 @@ sub construct_course { if (ref($crsinfo{$$crsudom.'_'.$$crsunum}) eq 'HASH') { $crsinfo{$$crsudom.'_'.$$crsunum}{'uniquecode'} = $code; my $putres = &Apache::lonnet::courseidput($$crsudom,\%crsinfo,$crsuhome,'notime'); - } + } if (ref($coderef)) { $$coderef = $code; } @@ -15665,17 +15782,12 @@ sub construct_course { # Open all assignments # if ($args->{'openall'}) { - my $opendate = time; - if ($args->{'openallfrom'} =~ /^\d+$/) { - $opendate = $args->{'openallfrom'}; - } my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate'; - my %storecontent = ($storeunder => $opendate, + my %storecontent = ($storeunder => time, $storeunder.'.type' => 'date_start'); - $outcome .= &mt('All assignments open starting [_1]', - &Apache::lonlocal::locallocaltime($opendate)).': '. - &Apache::lonnet::cput - ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; + + $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; } # # Set first page @@ -15705,7 +15817,31 @@ sub construct_course { $outcome .= ($fatal?$errtext:'write ok').$linefeed; } - return (1,$outcome,\@clonemsg); +# +# Set params for Placement Tests +# + if ($args->{'crstype'} eq 'Placement') { + my %storecontent; + my $prefix=$$crsudom.'_'.$$crsunum.'.0.'; + my %defaults = ( + buttonshide => { value => 'yes', + type => 'string_yesno',}, + type => { value => 'randomizetry', + type => 'string_questiontype',}, + maxtries => { value => 1, + type => 'int_pos',}, + problemstatus => { value => 'no', + type => 'string_problemstatus',}, + ); + foreach my $key (keys(%defaults)) { + $storecontent{$prefix.$key} = $defaults{$key}{'value'}; + $storecontent{$prefix.$key.'.type'} = $defaults{$key}{'type'}; + } + &Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum); + } + + return (1,$outcome); } sub make_unique_code { @@ -15718,7 +15854,7 @@ sub make_unique_code { my $tries = 0; my $gotlock = &Apache::lonnet::newput_dom('uniquecodes',$lockhash,$cdom); my ($code,$error); - + while (($gotlock ne 'ok') && ($tries<3)) { $tries ++; sleep 1; @@ -15765,8 +15901,7 @@ sub generate_code { ############################################################ ############################################################ -#SD -# only Community and Course, or anything else? +# Community, Course and Placement Test sub course_type { my ($cid) = @_; if (!defined($cid)) { @@ -15784,17 +15919,19 @@ sub group_term { my %names = ( 'Course' => 'group', 'Community' => 'group', + 'Placement' => 'group', ); return $names{$crstype}; } sub course_types { - my @types = ('official','unofficial','community','textbook'); + my @types = ('official','unofficial','community','textbook','placement'); my %typename = ( official => 'Official course', unofficial => 'Unofficial course', community => 'Community', textbook => 'Textbook course', + placement => 'Placement test', ); return (\@types,\%typename); } @@ -15881,8 +16018,6 @@ sub init_user_environment { my $public=($username eq 'public' && $domain eq 'public'); -# See if old ID present, if so, remove - my ($filename,$cookie,$userroles,$firstaccenv,$timerintenv); my $now=time; @@ -15904,28 +16039,13 @@ sub init_user_environment { } if (!$cookie) { $cookie="publicuser_$oldest"; } } else { - # if this isn't a robot, kill any existing non-robot sessions + # See if old ID present, if so, remove if this isn't a robot, + # killing any existing non-robot sessions if (!$args->{'robot'}) { opendir(DIR,$lonids); while ($filename=readdir(DIR)) { if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) { - if (tie(my %oldenv,'GDBM_File',"$lonids/$filename", - &GDBM_READER(),0640)) { - my $linkedfile; - if (exists($oldenv{'user.linkedenv'})) { - $linkedfile = $oldenv{'user.linkedenv'}; - } - untie(%oldenv); - if (unlink("$lonids/$filename")) { - if ($linkedfile =~ /^[a-f0-9]+_linked$/) { - if (-l "$lonids/$linkedfile.id") { - unlink("$lonids/$linkedfile.id"); - } - } - } - } else { - unlink($lonids.'/'.$filename); - } + unlink($lonids.'/'.$filename); } } closedir(DIR); @@ -15960,8 +16080,7 @@ sub init_user_environment { my %userenv = &Apache::lonnet::dump('environment',$domain,$username); my ($tmp) = keys(%userenv); - if ($tmp !~ /^(con_lost|error|no_such_host)/i) { - } else { + if ($tmp =~ /^(con_lost|error|no_such_host)/i) { undef(%userenv); } if (($userenv{'interface'}) && (!$form->{'interface'})) { @@ -15976,7 +16095,6 @@ sub init_user_environment { # --------------------------------------------------------- Write first profile { - my $ip = &Apache::lonnet::get_requestor_ip(); my %initial_env = ("user.name" => $username, "user.domain" => $domain, @@ -15995,7 +16113,7 @@ sub init_user_environment { "request.course.sec" => '', "request.role" => 'cm', "request.role.adv" => $env{'user.adv'}, - "request.host" => $ip,); + "request.host" => $ENV{'REMOTE_ADDR'},); if ($form->{'localpath'}) { $initial_env{"browser.localpath"} = $form->{'localpath'}; @@ -16033,7 +16151,7 @@ sub init_user_environment { undef,\%userenv,\%domdef,\%is_adv); } - foreach my $crstype ('official','unofficial','community','textbook') { + foreach my $crstype ('official','unofficial','community','textbook','placement') { $userenv{'canrequest.'.$crstype} = &Apache::lonnet::usertools_access($username,$domain,$crstype, 'reload','requestcourses', @@ -16047,7 +16165,7 @@ sub init_user_environment { my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'], $domain,$username); my $reqstatus = $reqauthor{'author_status'}; - if ($reqstatus eq 'approval' || $reqstatus eq 'approved') { + if ($reqstatus eq 'approval' || $reqstatus eq 'approved') { if (ref($reqauthor{'author'}) eq 'HASH') { $userenv{'requestauthorqueued'} = $reqstatus.':'. $reqauthor{'author'}{'timestamp'}; @@ -16158,12 +16276,12 @@ and quotacheck.pl Inputs: -filterlist - anonymous array of fields to include as potential filters +filterlist - anonymous array of fields to include as potential filters crstype - course type roleelement - fifth arg in selectcourse_link() populates fifth arg in javascript: opencrsbrowser() function, used - to pop-open a course selector (will contain "extra element"). + to pop-open a course selector (will contain "extra element"). multelement - if multiple course selections will be allowed, this will be a hidden form element: name: multiple; value: 1 @@ -16179,19 +16297,19 @@ cloneruname - username of owner of new c clonerudom - domain of owner of new course who wants to clone -typeelem - text to use for left column in row containing course type (i.e., Course, Community or Course/Community) +typeelem - text to use for left column in row containing course type (i.e., Course, Community or Course/Community) codetitlesref - reference to array of titles of components in institutional codes (official courses) codedom - domain -formname - value of form element named "form". +formname - value of form element named "form". fixeddom - domain, if fixed. -prevphase - value to assign to form element named "phase" when going back to the previous screen +prevphase - value to assign to form element named "phase" when going back to the previous screen -cnameelement - name of form element in form on opener page which will receive title of selected course +cnameelement - name of form element in form on opener page which will receive title of selected course cnumelement - name of form element in form on opener page which will receive courseID of selected course @@ -16282,15 +16400,19 @@ sub build_filters { $createdfilterform = &timebased_select_form('createdfilter',$filter); } + my $prefix = $crstype; + if ($crstype eq 'Placement') { + $prefix = 'Placement Test' + } my %lt = &Apache::lonlocal::texthash( - 'cac' => "$crstype Activity", - 'ccr' => "$crstype Created", - 'cde' => "$crstype Title", - 'cdo' => "$crstype Domain", + 'cac' => "$prefix Activity", + 'ccr' => "$prefix Created", + 'cde' => "$prefix Title", + 'cdo' => "$prefix Domain", 'ins' => 'Institutional Code', 'inc' => 'Institutional Categorization', - 'cow' => "$crstype Owner/Co-owner", - 'cop' => "$crstype Personnel Includes", + 'cow' => "$prefix Owner/Co-owner", + 'cop' => "$prefix Personnel Includes", 'cog' => 'Type', ); @@ -16298,6 +16420,8 @@ sub build_filters { my $typeval = 'Course'; if ($crstype eq 'Community') { $typeval = 'Community'; + } elsif ($crstype eq 'Placement') { + $typeval = 'Placement'; } $typeselectform = ''; } else { @@ -16306,9 +16430,15 @@ sub build_filters { $typeselectform .= ' onchange="'.$onchange.'"'; } $typeselectform .= '>'."\n"; - foreach my $posstype ('Course','Community') { + foreach my $posstype ('Course','Community','Placement') { + my $shown; + if ($posstype eq 'Placement') { + $shown = &mt('Placement Test'); + } else { + $shown = &mt($posstype); + } $typeselectform.='\n"; + ($posstype eq $crstype ? ' selected="selected" ' : ''). ">".$shown."\n"; } $typeselectform.=""; } @@ -16333,7 +16463,7 @@ sub build_filters { if (exists($filter->{'instcodefilter'})) { # if (($fixeddom) || ($formname eq 'requestcrs') || # ($formname eq 'modifycourse') || ($formname eq 'filterpicker')) { - if ($codedom) { + if ($codedom) { $officialjs = 1; ($instcodeform,$jscript,$$numtitlesref) = &Apache::courseclassifier::instcode_selectors($codedom,'filterpicker', @@ -16462,7 +16592,7 @@ $typeelement return $jscript.$clonewarning.$output; } -=pod +=pod =item * &timebased_select_form() @@ -16477,7 +16607,7 @@ item - name of form element (sincefilter filter - anonymous hash of criteria and their values Returns: HTML for a select box contained a blank, then six time selections, - with value set in incoming form variables currently selected. + with value set in incoming form variables currently selected. Side Effects: None @@ -16514,7 +16644,7 @@ page load completion for page showing se Inputs: None -Returns: markup containing updateFilters() and hideSearching() javascript functions. +Returns: markup containing updateFilters() and hideSearching() javascript functions. Side Effects: None @@ -16553,7 +16683,7 @@ to retrieve a hash for which keys are co Inputs: -dom - domain being searched +dom - domain being searched type - course type ('Course' or 'Community' or '.' if any). @@ -16565,7 +16695,7 @@ cloneruname - optional username of new c clonerudom - optional domain of new course owner -domcloner - optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by, +domcloner - optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by, (used when DC is using course creation form) codetitles - reference to array of titles of components in institutional codes (official courses). @@ -16575,8 +16705,8 @@ cc_clone - escaped comma separated list reqcrsdom - domain of new course, where search_courses is used to identify potential courses to clone -reqinstcode - institutional code of new course, where search_courses is used to identify potential - courses to clone +reqinstcode - institutional code of new course, where search_courses is used to identify potential + courses to clone Returns: %courses - hash of courses satisfying search criteria, keys = course IDs, values are corresponding colon-separated escaped description, institutional code, owner and type. @@ -16702,8 +16832,8 @@ $required - LON-CAPA version needed by c Returns: -$switchserver - query string tp append to /adm/switchserver call (if - current server's LON-CAPA version is too old. +$switchserver - query string tp append to /adm/switchserver call (if + current server's LON-CAPA version is too old. $warning - Message is displayed if no suitable server could be found. @@ -16816,7 +16946,7 @@ Inputs: $loncaparev - Version on current server (format: Major.Minor.Subrelease-datestamp) $interval (optional) - Time which may elapse (in s) between last check for content - change in current course. (default: 600 s). + change in current course. (default: 600 s). Returns: an array; first element is: @@ -16824,9 +16954,9 @@ Returns: an array; first element is: 'switch' - if content updates mean user's session needs to be switched to a server running a newer LON-CAPA version - + 'update' - if course session needs to be refreshed (i.e., Big Hash needs to be reloaded) - on current server hosting user's session + on current server hosting user's session '' - if no action required. @@ -16834,10 +16964,10 @@ Returns: an array; first element is: If first item element is 'switch': -second item is $switchwarning - Warning message if no suitable server found to host session. +second item is $switchwarning - Warning message if no suitable server found to host session. third item is $switchserver - query string to append to /adm/switchserver containing lonHostID - and current role. + and current role. otherwise: no other elements returned. @@ -16855,12 +16985,8 @@ sub needs_coursereinit { $interval = 600; } if (($now-$env{'request.course.timechecked'})>$interval) { - &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); - my $blocked = &blocking_status('reinit',$cnum,$cdom,undef,1); - if ($blocked) { - return (); - } my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum); + &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); if ($lastchange > $env{'request.course.tied'}) { my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); if ($curr_reqd_hash{'internal.releaserequired'} ne '') { @@ -17063,10 +17189,10 @@ sub symb_to_docspath { } sub captcha_display { - my ($context,$lonhost,$defdom) = @_; + my ($context,$lonhost) = @_; my ($output,$error); - my ($captcha,$pubkey,$privkey,$version) = - &get_captcha_config($context,$lonhost,$defdom); + my ($captcha,$pubkey,$privkey,$version) = + &get_captcha_config($context,$lonhost); if ($captcha eq 'original') { $output = &create_captcha(); unless ($output) { @@ -17082,9 +17208,9 @@ sub captcha_display { } sub captcha_response { - my ($context,$lonhost,$defdom) = @_; + my ($context,$lonhost) = @_; my ($captcha_chk,$captcha_error); - my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom); + my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost); if ($captcha eq 'original') { ($captcha_chk,$captcha_error) = &check_captcha(); } elsif ($captcha eq 'recaptcha') { @@ -17096,7 +17222,7 @@ sub captcha_response { } sub get_captcha_config { - my ($context,$lonhost,$dom_in_effect) = @_; + my ($context,$lonhost) = @_; my ($captcha,$pubkey,$privkey,$version,$hashtocheck); my $hostname = &Apache::lonnet::hostname($lonhost); my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname); @@ -17136,7 +17262,7 @@ sub get_captcha_config { $captcha = 'recaptcha'; $version = $domconfhash{$serverhomedom.'.login.recaptchaversion'}; if ($version ne '2') { - $version = 1; + $version = 1; } } else { $captcha = 'original'; @@ -17144,27 +17270,6 @@ sub get_captcha_config { } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') { $captcha = 'original'; } - } elsif ($context eq 'passwords') { - if ($dom_in_effect) { - my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect); - if ($passwdconf{'captcha'} eq 'recaptcha') { - if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') { - $pubkey = $passwdconf{'recaptchakeys'}{'public'}; - $privkey = $passwdconf{'recaptchakeys'}{'private'}; - } - if ($privkey && $pubkey) { - $captcha = 'recaptcha'; - $version = $passwdconf{'recaptchaversion'}; - if ($version ne '2') { - $version = 1; - } - } else { - $captcha = 'original'; - } - } elsif ($passwdconf{'captcha'} ne 'notused') { - $captcha = 'original'; - } - } } return ($captcha,$pubkey,$privkey,$version); } @@ -17239,20 +17344,19 @@ sub create_recaptcha { &mt('If the text is hard to read, [_1] will replace them.', 'reCAPTCHA refresh'). '

'; - } + } } sub check_recaptcha { my ($privkey,$version) = @_; my $captcha_chk; - my $ip = &Apache::lonnet::get_requestor_ip(); if ($version >= 2) { my $ua = LWP::UserAgent->new; $ua->timeout(10); my %info = ( - secret => $privkey, + secret => $privkey, response => $env{'form.g-recaptcha-response'}, - remoteip => $ip, + remoteip => $ENV{'REMOTE_ADDR'}, ); my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info); if ($response->is_success) { @@ -17268,7 +17372,7 @@ sub check_recaptcha { my $captcha_result = $captcha->check_answer( $privkey, - $ip, + $ENV{'REMOTE_ADDR'}, $env{'form.recaptcha_challenge_field'}, $env{'form.recaptcha_response_field'}, ); @@ -17317,37 +17421,21 @@ sub cleanup_html { # Checks for critical messages and returns a redirect url if one exists. # $interval indicates how often to check for messages. -# $context is the calling context -- roles, grades, contents, menu or flip. sub critical_redirect { - my ($interval,$context) = @_; + my ($interval) = @_; if ((time-$env{'user.criticalcheck.time'})>$interval) { - if (($env{'request.course.id'}) && (($context eq 'flip') || ($context eq 'contents'))) { - my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; - my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; - my $blocked = &blocking_status('alert',$cnum,$cdom,undef,1); - if ($blocked) { - my $checkrole = "cm./$cdom/$cnum"; - if ($env{'request.course.sec'} ne '') { - $checkrole .= "/$env{'request.course.sec'}"; - } - unless ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) && - ($env{'request.role'} !~ m{^st\./$cdom/$cnum})) { - return; - } - } - } - my @what=&Apache::lonnet::dump('critical', $env{'user.domain'}, + my @what=&Apache::lonnet::dump('critical', $env{'user.domain'}, $env{'user.name'}); &Apache::lonnet::appenv({'user.criticalcheck.time'=>time}); my $redirecturl; if ($what[0]) { - if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) { - $redirecturl='/adm/email?critical=display'; - my $url=&Apache::lonnet::absolute_url().$redirecturl; + if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) { + $redirecturl='/adm/email?critical=display'; + my $url=&Apache::lonnet::absolute_url().$redirecturl; return (1, $url); } } - } + } return (); } @@ -17401,299 +17489,6 @@ sub des_decrypt { return $plaintext; } -sub get_requested_shorturls { - my ($cdom,$cnum,$navmap) = @_; - return unless (ref($navmap)); - my ($numnew,$errors); - my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny'); - if (@toshorten) { - my (%maps,%resources,%titles); - &Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles, - 'shorturls',$cdom,$cnum); - if (keys(%resources)) { - my %tocreate; - foreach my $item (sort {$a <=> $b} (@toshorten)) { - my $symb = $resources{$item}; - if ($symb) { - $tocreate{$cnum.'&'.$symb} = 1; - } - } - if (keys(%tocreate)) { - ($numnew,$errors) = &make_short_symbs($cdom,$cnum, - \%tocreate); - } - } - } - return ($numnew,$errors); -} - -sub make_short_symbs { - my ($cdom,$cnum,$tocreateref,$lockuser) = @_; - my ($numnew,@errors); - if (ref($tocreateref) eq 'HASH') { - my %tocreate = %{$tocreateref}; - if (keys(%tocreate)) { - my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum); - my $su = Short::URL->new(no_vowels => 1); - my $init = ''; - my (%newunique,%addcourse,%courseonly,%failed); - # get lock on tiny db - my $now = time; - if ($lockuser eq '') { - $lockuser = $env{'user.name'}.':'.$env{'user.domain'}; - } - my $lockhash = { - "lock\0$now" => $lockuser, - }; - my $tries = 0; - my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); - my ($code,$error); - while (($gotlock ne 'ok') && ($tries<3)) { - $tries ++; - sleep 1; - $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); - } - if ($gotlock eq 'ok') { - $init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique, - \%addcourse,\%courseonly,\%failed); - if (keys(%failed)) { - my $numfailed = scalar(keys(%failed)); - push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed)); - } - if (keys(%newunique)) { - my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom); - if ($putres eq 'ok') { - $numnew = scalar(keys(%newunique)); - my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum); - unless ($newputres eq 'ok') { - push(@errors,&mt('error: could not store course look-up of short URLs')); - } - } else { - push(@errors,&mt('error: could not store unique six character URLs')); - } - } - } - } - } - return ($numnew,\@errors); -} - -sub shorten_symbs { - my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_; - return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') && - (ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') && - (ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH')); - my (%possibles,%collisions); - foreach my $key (keys(%{$tocreate})) { - my $num = String::CRC32::crc32($key); - my $tiny = $su->encode($num,$init); - if ($tiny) { - $possibles{$tiny} = $key; - } - } - if (!$init) { - $init = 1; - } else { - $init ++; - } - if (keys(%possibles)) { - my @posstiny = keys(%possibles); - my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); - my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname); - if (keys(%currtiny)) { - foreach my $key (keys(%currtiny)) { - next if ($currtiny{$key} eq ''); - if ($currtiny{$key} eq $possibles{$key}) { - my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key}); - unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) { - $courseonly->{$tsymb} = $key; - } - } else { - $collisions{$possibles{$key}} = 1; - } - delete($possibles{$key}); - } - } - foreach my $key (keys(%possibles)) { - $newunique->{$key} = $possibles{$key}; - my ($tcnum,$tsymb) = split(/\&/,$possibles{$key}); - unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) { - $addcourse->{$tsymb} = $key; - } - } - } - if (keys(%collisions)) { - if ($init <5) { - if (!$init) { - $init = 1; - } else { - $init ++; - } - $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions, - $newunique,$addcourse,$courseonly,$failed); - } else { - foreach my $key (keys(%collisions)) { - $failed->{$key} = 1; - $failed->{$key} = 1; - } - } - } - return $init; -} - -sub is_nonframeable { - my ($url,$absolute,$hostname,$ip,$nocache) = @_; - my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i); - return if (($remprotocol eq '') || ($remhost eq '')); - - $remprotocol = lc($remprotocol); - $remhost = lc($remhost); - my $remport = 80; - if ($remprotocol eq 'https') { - $remport = 443; - } - my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport); - if ($cached) { - unless ($nocache) { - if ($result) { - return 1; - } else { - return 0; - } - } - } - my $uselink; - my $request = new HTTP::Request('HEAD',$url); - my $ua = LWP::UserAgent->new; - $ua->timeout(5); - my $response=$ua->request($request); - if ($response->is_success()) { - my $secpolicy = lc($response->header('content-security-policy')); - my $xframeop = lc($response->header('x-frame-options')); - $secpolicy =~ s/^\s+|\s+$//g; - $xframeop =~ s/^\s+|\s+$//g; - if (($secpolicy ne '') || ($xframeop ne '')) { - my $remotehost = $remprotocol.'://'.$remhost; - my ($origin,$protocol,$port); - if ($ENV{'SERVER_PORT'} =~/^\d+$/) { - $port = $ENV{'SERVER_PORT'}; - } else { - $port = 80; - } - if ($absolute eq '') { - $protocol = 'http:'; - if ($port == 443) { - $protocol = 'https:'; - } - $origin = $protocol.'//'.lc($hostname); - } else { - $origin = lc($absolute); - ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$}); - } - if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;|$)/)) { - my $framepolicy = $1; - $framepolicy =~ s/^\s+|\s+$//g; - my @policies = split(/\s+/,$framepolicy); - if (@policies) { - if (grep(/^\Q'none'\E$/,@policies)) { - $uselink = 1; - } else { - $uselink = 1; - if ((grep(/^\Q*\E$/,@policies)) || (grep(/^\Q$protocol\E$/,@policies)) || - (($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) || - (($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) { - undef($uselink); - } - if ($uselink) { - if (grep(/^\Q'self'\E$/,@policies)) { - if (($origin ne '') && ($remotehost eq $origin)) { - undef($uselink); - } - } - } - if ($uselink) { - my @possok; - if ($ip ne '') { - push(@possok,$ip); - } - my $hoststr = ''; - foreach my $part (reverse(split(/\./,$hostname))) { - if ($hoststr eq '') { - $hoststr = $part; - } else { - $hoststr = "$part.$hoststr"; - } - if ($hoststr eq $hostname) { - push(@possok,$hostname); - } else { - push(@possok,"*.$hoststr"); - } - } - if (@possok) { - foreach my $poss (@possok) { - last if (!$uselink); - foreach my $policy (@policies) { - if ($policy =~ m{^(\Q$protocol\E//|)\Q$poss\E(\Q:$port\E|)$}) { - undef($uselink); - last; - } - } - } - } - } - } - } - } elsif ($xframeop ne '') { - $uselink = 1; - my @policies = split(/\s*,\s*/,$xframeop); - if (@policies) { - unless (grep(/^deny$/,@policies)) { - if ($origin ne '') { - if (grep(/^sameorigin$/,@policies)) { - if ($remotehost eq $origin) { - undef($uselink); - } - } - if ($uselink) { - foreach my $policy (@policies) { - if ($policy =~ /^allow-from\s*(.+)$/) { - my $allowfrom = $1; - if (($allowfrom ne '') && ($allowfrom eq $origin)) { - undef($uselink); - last; - } - } - } - } - } - } - } - } - } - } - if ($nocache) { - if ($cached) { - my $devalidate; - if ($uselink && !$result) { - $devalidate = 1; - } elsif (!$uselink && $result) { - $devalidate = 1; - } - if ($devalidate) { - &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport); - } - } - } else { - if ($uselink) { - $result = 1; - } else { - $result = 0; - } - &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600); - } - return $uselink; -} - 1; __END__;