--- loncom/interface/loncommon.pm 2016/10/03 19:40:17 1.1254
+++ loncom/interface/loncommon.pm 2020/02/19 23:19:52 1.1339
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1254 2016/10/03 19:40:17 raeburn Exp $
+# $Id: loncommon.pm,v 1.1339 2020/02/19 23:19:52 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -71,6 +71,8 @@ use Apache::lonuserutils();
use Apache::lonuserstate();
use Apache::courseclassifier();
use LONCAPA qw(:DEFAULT :match);
+use LONCAPA::LWPReq;
+use HTTP::Request;
use DateTime::TimeZone;
use DateTime::Locale;
use Encode();
@@ -78,11 +80,14 @@ 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 MIME::Lite;
use MIME::Types;
+use File::Copy();
+use File::Path();
+use String::CRC32();
+use Short::URL();
# ---------------------------------------------- Designs
use vars qw(%defaultdesign);
@@ -198,7 +203,7 @@ 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);
@@ -220,7 +225,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 +239,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 +253,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,12 +267,12 @@ 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);
my ($extension,$category)=(split(/\s+/,$line,2));
- push @{$category_extensions{lc($category)}},$extension;
+ push(@{$category_extensions{lc($category)}},$extension);
}
close($fh);
}
@@ -277,7 +282,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 +435,7 @@ sub studentbrowser_javascript {
<script type="text/javascript" language="Javascript">
// <![CDATA[
var stdeditbrowser;
- function openstdbrowser(formname,uname,udom,clicker,roleflag,ignorefilter,courseadvonly) {
+ function openstdbrowser(formname,uname,udom,clicker,roleflag,ignorefilter,courseadv) {
var url = '/adm/pickstudent?';
var filter;
if (!ignorefilter) {
@@ -445,7 +450,12 @@ sub studentbrowser_javascript {
'&udomelement='+udom+
'&clicker='+clicker;
if (roleflag) { url+="&roles=1"; }
- if (courseadvonly) { url+="&courseadvonly=1"; }
+ if (courseadv == 'condition') {
+ if (document.getElementById('courseadv')) {
+ courseadv = document.getElementById('courseadv').value;
+ }
+ }
+ if ((courseadv == 'only') || (courseadv == 'none')) { url+="&courseadv="+courseadv; }
var title = 'Student_Browser';
var options = 'scrollbars=1,resizable=1,menubar=0';
options += ',width=700,height=600';
@@ -477,7 +487,7 @@ ENDRESBRW
}
sub selectstudent_link {
- my ($form,$unameele,$udomele,$courseadvonly,$clickerid)=@_;
+ my ($form,$unameele,$udomele,$courseadv,$clickerid)=@_;
my $callargs = "'".&Apache::lonhtmlcommon::entity_encode($form)."','".
&Apache::lonhtmlcommon::entity_encode($unameele)."','".
&Apache::lonhtmlcommon::entity_encode($udomele)."'";
@@ -488,8 +498,12 @@ sub selectstudent_link {
return '';
}
$callargs.=",'".&Apache::lonhtmlcommon::entity_encode($clickerid)."'";
- if ($courseadvonly) {
- $callargs .= ",'',1,1";
+ if ($courseadv eq 'only') {
+ $callargs .= ",'',1,'$courseadv'";
+ } elsif ($courseadv eq 'none') {
+ $callargs .= ",'','','$courseadv'";
+ } elsif ($courseadv eq 'condition') {
+ $callargs .= ",'','','$courseadv'";
}
return '<span class="LC_nobreak">'.
'<a href="javascript:openstdbrowser('.$callargs.');">'.
@@ -943,8 +957,8 @@ ENDSCRT
}
sub select_timezone {
- my ($name,$selected,$onchange,$includeempty)=@_;
- my $output='<select name="'.$name.'" '.$onchange.'>'."\n";
+ my ($name,$selected,$onchange,$includeempty,$disabled)=@_;
+ my $output='<select name="'.$name.'" '.$onchange.$disabled.'>'."\n";
if ($includeempty) {
$output .= '<option value=""';
if (($selected eq '') || ($selected eq 'local')) {
@@ -965,8 +979,8 @@ sub select_timezone {
}
sub select_datelocale {
- my ($name,$selected,$onchange,$includeempty)=@_;
- my $output='<select name="'.$name.'" '.$onchange.'>'."\n";
+ my ($name,$selected,$onchange,$includeempty,$disabled)=@_;
+ my $output='<select name="'.$name.'" '.$onchange.$disabled.'>'."\n";
if ($includeempty) {
$output .= '<option value=""';
if ($selected eq '') {
@@ -1018,7 +1032,7 @@ sub select_datelocale {
}
sub select_language {
- my ($name,$selected,$includeempty) = @_;
+ my ($name,$selected,$includeempty,$noedit) = @_;
my %langchoices;
if ($includeempty) {
%langchoices = ('' => 'No language preference');
@@ -1030,7 +1044,7 @@ sub select_language {
}
}
%langchoices = &Apache::lonlocal::texthash(%langchoices);
- return &select_form($selected,$name,\%langchoices);
+ return &select_form($selected,$name,\%langchoices,undef,$noedit);
}
=pod
@@ -1054,7 +1068,7 @@ sub list_languages {
if ($code) {
my $selector = $supported_codes{$id};
my $description = &plainlanguagedescription($id);
- push (@lang_choices, [$selector, $description]);
+ push(@lang_choices, [$selector, $description]);
}
}
return \@lang_choices;
@@ -1176,7 +1190,7 @@ sub linked_select_forms {
$result.="select2data${suffix}['d_$s1'].texts = new Array(";
my @s2texts;
foreach my $value (@s2values) {
- push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
+ push(@s2texts, $hashref->{$s1}->{'select2'}->{$value});
}
$result.="\"@s2texts\");\n";
}
@@ -1292,9 +1306,13 @@ sub help_open_topic {
}
# Add the text
+ my $target = ' target="_top"';
+ if (($env{'request.lti.login'}) && ($env{'request.lti.target'} eq 'iframe')) {
+ $target = '';
+ }
if ($text ne "") {
$template.='<span class="LC_help_open_topic">'
- .'<a target="_top" href="'.$link.'">'
+ .'<a'.$target.' href="'.$link.'">'
.$text.'</a>';
}
@@ -1304,7 +1322,7 @@ sub help_open_topic {
if ($imgid ne '') {
$imgid = ' id="'.$imgid.'"';
}
- $template.=' <a target="_top" href="'.$link.'" title="'.$title.'">'
+ $template.=' <a'.$target.' href="'.$link.'" title="'.$title.'">'
.'<img src="'.$helpicon.'" border="0"'
.' alt="'.&mt('Help: [_1]',$topic).'"'
.' title="'.$title.'" style="vertical-align:middle;"'.$imgid
@@ -1497,19 +1515,24 @@ sub help_open_bug {
{
$link = $url;
}
+
+ my $target = ' target="_top"';
+ if (($env{'request.lti.login'}) && ($env{'request.lti.target'} eq 'iframe')) {
+ $target = '';
+ }
# Add the text
if ($text ne "")
{
$template .=
"<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
- "<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><span style=\"color:#FFFFFF;font-size:10pt;\">$text</span></a>";
+ "<td bgcolor='#FF5555'><a".$target." href=\"$link\"><span style=\"color:#FFFFFF;font-size:10pt;\">$text</span></a>";
}
# Add the graphic
my $title = &mt('Report a Bug');
my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
$template .= <<"ENDTEMPLATE";
- <a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
+ <a$target href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
ENDTEMPLATE
if ($text ne '') { $template.='</td></tr></table>' };
return $template;
@@ -2185,7 +2208,7 @@ sub crsauthor_url {
}
sub import_crsauthor_form {
- my ($form,$firstselectname,$secondselectname,$onchangefirst,$only,$suffix) = @_;
+ 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'};
@@ -2220,6 +2243,7 @@ sub import_crsauthor_form {
}
my @ordered = ();
foreach my $file (sort { lc($a) cmp lc($b) } (keys(%{$files{$key}}))) {
+ next if ($file =~ /\.rights$/);
if ($only) {
my ($ext) = ($file =~ /\.([^.]+)$/);
unless ($possexts{lc($ext)}) {
@@ -2263,11 +2287,13 @@ sub import_crsauthor_form {
unless ($possexts{lc($ext)}) {
next;
}
+ } else {
+ next if ($file =~ /\.rights$/);
}
push(@singledirfiles,$file);
}
if (@singledirfiles) {
- $possdirs == 1;
+ $possdirs = 1;
}
}
if (($possdirs == 1) && (@singledirfiles)) {
@@ -2476,10 +2502,24 @@ sub create_text_file {
# ------------------------------------------
sub domain_select {
- my ($name,$value,$multiple)=@_;
+ my ($name,$value,$multiple,$incdoms,$excdoms)=@_;
+ my @possdoms;
+ if (ref($incdoms) eq 'ARRAY') {
+ @possdoms = @{$incdoms};
+ } else {
+ @possdoms = &Apache::lonnet::all_domains();
+ }
+
my %domains=map {
$_ => $_.' '. &Apache::lonnet::domain($_,'description')
- } &Apache::lonnet::all_domains();
+ } @possdoms;
+
+ if ((ref($excdoms) eq 'ARRAY') && (@{$excdoms} > 0)) {
+ foreach my $dom (@{$excdoms}) {
+ delete($domains{$dom});
+ }
+ }
+
if ($multiple) {
$domains{''}=&mt('Any domain');
$domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
@@ -2742,7 +2782,7 @@ sub select_level_form {
=pod
-=item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms)
+=item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms,$disabled)
Returns a string containing a <select name='$name' size='1'> form to
allow a user to select the domain to preform an operation in.
@@ -2759,14 +2799,19 @@ 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.
+
=cut
#-------------------------------------------
sub select_dom_form {
- my ($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms) = @_;
+ my ($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms,$disabled) = @_;
if ($onchange) {
$onchange = ' onchange="'.$onchange.'"';
}
+ if ($disabled) {
+ $disabled = ' disabled="disabled"';
+ }
my (@domains,%exclude);
if (ref($incdoms) eq 'ARRAY') {
@domains = sort {lc($a) cmp lc($b)} (@{$incdoms});
@@ -2777,7 +2822,7 @@ sub select_dom_form {
if (ref($excdoms) eq 'ARRAY') {
map { $exclude{$_} = 1; } @{$excdoms};
}
- my $selectdomain = "<select name=\"$name\" size=\"1\"$onchange>\n";
+ my $selectdomain = "<select name=\"$name\" size=\"1\"$onchange$disabled>\n";
foreach my $dom (@domains) {
next if ($exclude{$dom});
$selectdomain.="<option value=\"$dom\" ".
@@ -3003,6 +3048,8 @@ This is not an optimal method, but it wo
=item * authform_filesystem
+=item * authform_lti
+
=back
See loncreateuser.pm for invocation and use examples.
@@ -3153,13 +3200,16 @@ sub authform_kerberos {
@_,
);
my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,
- $autharg,$jscall);
+ $autharg,$jscall,$disabled);
my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
if ($in{'kerb_def_auth'} eq 'krb5') {
$check5 = ' checked="checked"';
} else {
$check4 = ' checked="checked"';
}
+ if ($in{'readonly'}) {
+ $disabled = ' disabled="disabled"';
+ }
$krbarg = $in{'kerb_def_dom'};
if (defined($in{'curr_authtype'})) {
if ($in{'curr_authtype'} eq 'krb') {
@@ -3204,7 +3254,7 @@ sub authform_kerberos {
if (defined($in{'mode'})) {
if ($in{'mode'} eq 'modifycourse') {
if ($authnum == 1) {
- $authtype = '<input type="radio" name="login" value="krb" />';
+ $authtype = '<input type="radio" name="login" value="krb"'.$disabled.' />';
}
}
}
@@ -3213,7 +3263,7 @@ sub authform_kerberos {
if ($authtype eq '') {
$authtype = '<input type="radio" name="login" value="krb" '.
'onclick="'.$jscall.'" onchange="'.$jscall.'"'.
- $krbcheck.' />';
+ $krbcheck.$disabled.' />';
}
if (($can_assign{'krb4'} && $can_assign{'krb5'}) ||
($can_assign{'krb4'} && !$can_assign{'krb5'} &&
@@ -3226,9 +3276,9 @@ sub authform_kerberos {
'<label>'.$authtype,
'</label><input type="text" size="10" name="krbarg" '.
'value="'.$krbarg.'" '.
- 'onchange="'.$jscall.'" />',
- '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
- '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
+ 'onchange="'.$jscall.'"'.$disabled.' />',
+ '<label><input type="radio" name="krbver" value="4" '.$check4.$disabled.' />',
+ '</label><label><input type="radio" name="krbver" value="5" '.$check5.$disabled.' />',
'</label>');
} elsif ($can_assign{'krb4'}) {
$result .= &mt
@@ -3237,7 +3287,7 @@ sub authform_kerberos {
'<label>'.$authtype,
'</label><input type="text" size="10" name="krbarg" '.
'value="'.$krbarg.'" '.
- 'onchange="'.$jscall.'" />',
+ 'onchange="'.$jscall.'"'.$disabled.' />',
'<label><input type="hidden" name="krbver" value="4" />',
'</label>');
} elsif ($can_assign{'krb5'}) {
@@ -3247,7 +3297,7 @@ sub authform_kerberos {
'<label>'.$authtype,
'</label><input type="text" size="10" name="krbarg" '.
'value="'.$krbarg.'" '.
- 'onchange="'.$jscall.'" />',
+ 'onchange="'.$jscall.'"'.$disabled.' />',
'<label><input type="hidden" name="krbver" value="5" />',
'</label>');
}
@@ -3260,8 +3310,11 @@ sub authform_internal {
kerb_def_dom => 'MSU.EDU',
@_,
);
- my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall);
+ my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall,$disabled);
my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
+ if ($in{'readonly'}) {
+ $disabled = ' disabled="disabled"';
+ }
if (defined($in{'curr_authtype'})) {
if ($in{'curr_authtype'} eq 'int') {
if ($can_assign{'int'}) {
@@ -3290,7 +3343,7 @@ sub authform_internal {
if (defined($in{'mode'})) {
if ($in{'mode'} eq 'modifycourse') {
if ($authnum == 1) {
- $authtype = '<input type="radio" name="login" value="int" />';
+ $authtype = '<input type="radio" name="login" value="int"'.$disabled.' />';
}
}
}
@@ -3298,14 +3351,14 @@ sub authform_internal {
$jscall = "javascript:changed_radio('int',$in{'formname'});";
if ($authtype eq '') {
$authtype = '<input type="radio" name="login" value="int" '.$intcheck.
- ' onchange="'.$jscall.'" onclick="'.$jscall.'" />';
+ ' onchange="'.$jscall.'" onclick="'.$jscall.'"'.$disabled.' />';
}
$autharg = '<input type="password" size="10" name="intarg" value="'.
- $intarg.'" onchange="'.$jscall.'" />';
+ $intarg.'" onchange="'.$jscall.'"'.$disabled.' />';
$result = &mt
('[_1] Internally authenticated (with initial password [_2])',
'<label>'.$authtype,'</label>'.$autharg);
- $result.="<label><input type=\"checkbox\" name=\"visible\" onclick='if (this.checked) { this.form.intarg.type=\"text\" } else { this.form.intarg.type=\"password\" }' />".&mt('Visible input').'</label>';
+ $result.='<label><input type="checkbox" name="visible" onclick="if (this.checked) { this.form.intarg.type='."'text'".' } else { this.form.intarg.type='."'password'".' }"'.$disabled.' />'.&mt('Visible input').'</label>';
return $result;
}
@@ -3315,8 +3368,11 @@ sub authform_local {
kerb_def_dom => 'MSU.EDU',
@_,
);
- my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall);
+ my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall,$disabled);
my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
+ if ($in{'readonly'}) {
+ $disabled = ' disabled="disabled"';
+ }
if (defined($in{'curr_authtype'})) {
if ($in{'curr_authtype'} eq 'loc') {
if ($can_assign{'loc'}) {
@@ -3345,7 +3401,7 @@ sub authform_local {
if (defined($in{'mode'})) {
if ($in{'mode'} eq 'modifycourse') {
if ($authnum == 1) {
- $authtype = '<input type="radio" name="login" value="loc" />';
+ $authtype = '<input type="radio" name="login" value="loc"'.$disabled.' />';
}
}
}
@@ -3354,10 +3410,10 @@ sub authform_local {
if ($authtype eq '') {
$authtype = '<input type="radio" name="login" value="loc" '.
$loccheck.' onchange="'.$jscall.'" onclick="'.
- $jscall.'" />';
+ $jscall.'"'.$disabled.' />';
}
$autharg = '<input type="text" size="10" name="locarg" value="'.
- $locarg.'" onchange="'.$jscall.'" />';
+ $locarg.'" onchange="'.$jscall.'"'.$disabled.' />';
$result = &mt('[_1] Local Authentication with argument [_2]',
'<label>'.$authtype,'</label>'.$autharg);
return $result;
@@ -3369,8 +3425,11 @@ sub authform_filesystem {
kerb_def_dom => 'MSU.EDU',
@_,
);
- my ($fsyscheck,$result,$authtype,$autharg,$jscall);
+ my ($fsyscheck,$result,$authtype,$autharg,$jscall,$disabled);
my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
+ if ($in{'readonly'}) {
+ $disabled = ' disabled="disabled"';
+ }
if (defined($in{'curr_authtype'})) {
if ($in{'curr_authtype'} eq 'fsys') {
if ($can_assign{'fsys'}) {
@@ -3383,7 +3442,7 @@ sub authform_filesystem {
} else {
$result = &mt('Currently Filesystem Authenticated.');
return $result;
- }
+ }
}
} else {
if ($authnum == 1) {
@@ -3396,7 +3455,7 @@ sub authform_filesystem {
if (defined($in{'mode'})) {
if ($in{'mode'} eq 'modifycourse') {
if ($authnum == 1) {
- $authtype = '<input type="radio" name="login" value="fsys" />';
+ $authtype = '<input type="radio" name="login" value="fsys"'.$disabled.' />';
}
}
}
@@ -3405,16 +3464,71 @@ sub authform_filesystem {
if ($authtype eq '') {
$authtype = '<input type="radio" name="login" value="fsys" '.
$fsyscheck.' onchange="'.$jscall.'" onclick="'.
- $jscall.'" />';
+ $jscall.'"'.$disabled.' />';
}
- $autharg = '<input type="text" size="10" name="fsysarg" value=""'.
- ' onchange="'.$jscall.'" />';
+ $autharg = '<input type="password" size="10" name="fsysarg" value=""'.
+ ' onchange="'.$jscall.'"'.$disabled.' />';
$result = &mt
('[_1] Filesystem Authenticated (with initial password [_2])',
- '<label><input type="radio" name="login" value="fsys" '.
- $fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
- '</label><input type="password" size="10" name="fsysarg" value="" '.
- 'onchange="'.$jscall.'" />');
+ '<label>'.$authtype,'</label>'.$autharg);
+ return $result;
+}
+
+sub authform_lti {
+ my %in = (
+ formname => 'document.cu',
+ kerb_def_dom => 'MSU.EDU',
+ @_,
+ );
+ my ($lticheck,$result,$authtype,$autharg,$jscall,$disabled);
+ my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
+ if ($in{'readonly'}) {
+ $disabled = ' disabled="disabled"';
+ }
+ if (defined($in{'curr_authtype'})) {
+ if ($in{'curr_authtype'} eq 'lti') {
+ if ($can_assign{'lti'}) {
+ $lticheck = 'checked="checked" ';
+ if (defined($in{'mode'})) {
+ if ($in{'mode'} eq 'modifyuser') {
+ $lticheck = '';
+ }
+ }
+ } else {
+ $result = &mt('Currently LTI Authenticated.');
+ return $result;
+ }
+ }
+ } else {
+ if ($authnum == 1) {
+ $authtype = '<input type="hidden" name="login" value="lti" />';
+ }
+ }
+ if (!$can_assign{'lti'}) {
+ return;
+ } elsif ($authtype eq '') {
+ if (defined($in{'mode'})) {
+ if ($in{'mode'} eq 'modifycourse') {
+ if ($authnum == 1) {
+ $authtype = '<input type="radio" name="login" value="lti"'.$disabled.' />';
+ }
+ }
+ }
+ }
+ $jscall = "javascript:changed_radio('lti',$in{'formname'});";
+ if (($authtype eq '') && (($in{'mode'} eq 'modifycourse') || ($in{'curr_authtype'} ne 'lti'))) {
+ $authtype = '<input type="radio" name="login" value="lti" '.
+ $lticheck.' onchange="'.$jscall.'" onclick="'.
+ $jscall.'"'.$disabled.' />';
+ }
+ $autharg = '<input type="hidden" name="ltiarg" value="" />';
+ if ($authtype) {
+ $result = &mt('[_1] LTI Authenticated',
+ '<label>'.$authtype.'</label>'.$autharg);
+ } else {
+ $result = '<b>'.&mt('LTI Authenticated').'</b>'.
+ $autharg;
+ }
return $result;
}
@@ -3428,6 +3542,7 @@ sub get_assignable_auth {
krb5 => 1,
int => 1,
loc => 1,
+ lti => 1,
);
my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);
if (ref($domconfig{'usercreation'}) eq 'HASH') {
@@ -3436,7 +3551,7 @@ sub get_assignable_auth {
my $context;
if ($env{'request.role'} =~ /^au/) {
$context = 'author';
- } elsif ($env{'request.role'} =~ /^dc/) {
+ } elsif ($env{'request.role'} =~ /^(dc|dh)/) {
$context = 'domain';
} elsif ($env{'request.course.id'}) {
$context = 'course';
@@ -3460,6 +3575,79 @@ sub get_assignable_auth {
return ($authnum,%can_assign);
}
+sub check_passwd_rules {
+ my ($domain,$plainpass) = @_;
+ my %passwdconf = &Apache::lonnet::get_passwdconf($domain);
+ my ($min,$max,@chars,@brokerule,$warning);
+ $min = $Apache::lonnet::passwdmin;
+ if (ref($passwdconf{'chars'}) eq 'ARRAY') {
+ if ($passwdconf{'min'} =~ /^\d+$/) {
+ if ($passwdconf{'min'} > $min) {
+ $min = $passwdconf{'min'};
+ }
+ }
+ if ($passwdconf{'max'} =~ /^\d+$/) {
+ $max = $passwdconf{'max'};
+ }
+ @chars = @{$passwdconf{'chars'}};
+ }
+ if (($min) && (length($plainpass) < $min)) {
+ push(@brokerule,'min');
+ }
+ if (($max) && (length($plainpass) > $max)) {
+ push(@brokerule,'max');
+ }
+ if (@chars) {
+ my %rules;
+ map { $rules{$_} = 1; } @chars;
+ if ($rules{'uc'}) {
+ unless ($plainpass =~ /[A-Z]/) {
+ push(@brokerule,'uc');
+ }
+ }
+ if ($rules{'lc'}) {
+ unless ($plainpass =~ /[a-z]/) {
+ push(@brokerule,'lc');
+ }
+ }
+ if ($rules{'num'}) {
+ unless ($plainpass =~ /\d/) {
+ push(@brokerule,'num');
+ }
+ }
+ if ($rules{'spec'}) {
+ unless ($plainpass =~ /[!"#$%&'()*+,\-.\/:;<=>?@[\\\]^_`{|}~]/) {
+ push(@brokerule,'spec');
+ }
+ }
+ }
+ if (@brokerule) {
+ my %rulenames = &Apache::lonlocal::texthash(
+ uc => 'At least one upper case letter',
+ lc => 'At least one lower case letter',
+ num => 'At least one number',
+ spec => 'At least one non-alphanumeric',
+ );
+ $rulenames{'uc'} .= ': ABCDEFGHIJKLMNOPQRSTUVWXYZ';
+ $rulenames{'lc'} .= ': abcdefghijklmnopqrstuvwxyz';
+ $rulenames{'num'} .= ': 0123456789';
+ $rulenames{'spec'} .= ': !"\#$%&\'()*+,-./:;<=>?@[\]^_\`{|}~';
+ $rulenames{'min'} = &mt('Minimum password length: [_1]',$min);
+ $rulenames{'max'} = &mt('Maximum password length: [_1]',$max);
+ $warning = &mt('Password did not satisfy the following:').'<ul>';
+ foreach my $rule ('min','max','uc','lc','num','spec') {
+ if (grep(/^$rule$/,@brokerule)) {
+ $warning .= '<li>'.$rulenames{$rule}.'</li>';
+ }
+ }
+ $warning .= '</ul>';
+ }
+ if (wantarray) {
+ return @brokerule;
+ }
+ return $warning;
+}
+
###############################################################
## Get Kerberos Defaults for Domain ##
###############################################################
@@ -4545,9 +4733,15 @@ sub get_previous_attempt {
}
$prevattempts.= &end_data_table_row().&end_data_table();
} else {
+ my $msg;
+ if ($symb =~ /ext\.tool$/) {
+ $msg = &mt('No grade passed back.');
+ } else {
+ $msg = &mt('Nothing submitted - no attempts.');
+ }
$prevattempts=
&start_data_table().&start_data_table_row().
- '<td>'.&mt('Nothing submitted - no attempts.').'</td>'.
+ '<td>'.$msg.'</td>'.
&end_data_table_row().&end_data_table();
}
} else {
@@ -4652,6 +4846,9 @@ sub get_student_view {
}
if (defined($target)) { $form{'grade_target'} = $target; }
$feedurl=&Apache::lonnet::clutter($feedurl);
+ if (($feedurl =~ /ext\.tool$/) && ($target eq 'tex')) {
+ $feedurl =~ s{^/adm/wrapper}{};
+ }
my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
$userview=~s/\<body[^\>]*\>//gi;
$userview=~s/\<\/body\>//gi;
@@ -4974,7 +5171,8 @@ sub blockcheck {
# boards, chat or groups, check for blocking in current course only.
if (($activity eq 'boards' || $activity eq 'chat' ||
- $activity eq 'groups' || $activity eq 'printout') &&
+ $activity eq 'groups' || $activity eq 'printout' ||
+ $activity eq 'reinit' || $activity eq 'alert') &&
($env{'request.course.id'})) {
foreach my $key (keys(%live_courses)) {
if ($key ne $env{'request.course.id'}) {
@@ -5058,7 +5256,7 @@ sub blockcheck {
$tdom,$spec,$trest,$area);
}
}
- my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
+ my ($author,$adv,$rar) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
if ($1) {
$no_userblock = 1;
@@ -5080,9 +5278,9 @@ sub blockcheck {
($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
next if ($no_userblock);
- # Retrieve blocking times and identity of locker for course
+ # Retrieve blocking times and identity of blocker for course
# of specified user, unless user has 'evb' privilege.
-
+
my ($start,$end,$trigger) =
&get_blocks($setters,$activity,$cdom,$cnum,$url);
if (($start != 0) &&
@@ -5169,13 +5367,19 @@ sub get_blocks {
my $end = $start + $env{'course.'.$cdom.'_'.$cnum.'.timerinterval.'.$timersymb};
if ($start && $end) {
if (($start <= time) && ($end >= time)) {
- unless (grep(/^\Q$block\E$/,@blockers)) {
- push(@blockers,$block);
- $triggered{$block} = {
- start => $start,
- end => $end,
- type => $type,
- };
+ if (ref($commblocks{$block}) eq 'HASH') {
+ if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
+ if ($commblocks{$block}{'blocks'}{$activity} eq 'on') {
+ unless(grep(/^\Q$block\E$/,@blockers)) {
+ push(@blockers,$block);
+ $triggered{$block} = {
+ start => $start,
+ end => $end,
+ type => $type,
+ };
+ }
+ }
+ }
}
}
}
@@ -5285,6 +5489,10 @@ END_MYBLOCK
$text = &mt('Printing Blocked');
} elsif ($activity eq 'passwd') {
$text = &mt('Password Changing Blocked');
+ } elsif ($activity eq 'alert') {
+ $text = &mt('Checking Critical Messages Blocked');
+ } elsif ($activity eq 'reinit') {
+ $text = &mt('Checking Course Update Blocked');
}
$output .= <<"END_BLOCK";
<div class='$class'>
@@ -5308,8 +5516,13 @@ sub check_ip_acc {
if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
return 1;
}
- my $allowed;
- my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'};
+ my ($ip,$allowed);
+ if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') ||
+ ($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) {
+ $ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip;
+ } else {
+ $ip = $ENV{'REMOTE_ADDR'} || $env{'request.host'} || $clientip;
+ }
my $name;
my %access = (
@@ -5524,7 +5737,7 @@ sub get_legacy_domconf {
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
my $designfile = $designdir.'/'.$udom.'.tab';
if (-e $designfile) {
- if ( open (my $fh,"<$designfile") ) {
+ if ( open (my $fh,'<',$designfile) ) {
while (my $line = <$fh>) {
next if ($line =~ /^\#/);
chomp($line);
@@ -5723,13 +5936,18 @@ sub CSTR_pageheader {
$title = &mt('Authoring Space');
}
+ my ($target,$crumbtarget) = (' target="_top"','_top'); #FIXME lonpubdir: target="_parent"
+ if (($env{'request.lti.login'}) && ($env{'request.lti.target'} eq 'iframe')) {
+ $target = '';
+ $crumbtarget = '';
+ }
+
my $output =
'<div>'
.&Apache::loncommon::help_open_menu('','',3,'Authoring') #FIXME: Broken? Where is it?
.'<b>'.$title.'</b> '
- .'<form name="dirs" method="post" action="'.$formaction
- .'" target="_top">' #FIXME lonpubdir: target="_parent"
- .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv/'.$udom,undef,undef);
+ .'<form name="dirs" method="post" action="'.$formaction.'"'.$target.'>'
+ .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,$crumbtarget,'/priv/'.$udom,undef,undef);
if ($lastitem) {
$output .=
@@ -5743,7 +5961,7 @@ sub CSTR_pageheader {
} else {
$output .=
'<br />'
- #FIXME lonpubdir: &Apache::lonhtmlcommon::crumbs($uname.$thisdisfn.'/','_top','/priv','','+1',1)."</b></tt><br />"
+ #FIXME lonpubdir: &Apache::lonhtmlcommon::crumbs($uname.$thisdisfn.'/',$crumbtarget,'/priv','','+1',1)."</b></tt><br />"
.&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
.'</form>'
.&Apache::lonmenu::constspaceform();
@@ -5792,11 +6010,28 @@ Inputs:
=item * $args, optional argument valid values are
no_auto_mt_title -> prevents &mt()ing the title arg
+ use_absolute -> for external resource or syllabus, this will
+ contain https://<hostname> if server uses
+ https (as per hosts.tab), but request is for http
+ hostname -> hostname, from $r->hostname().
=item * $advtoolsref, optional argument, ref to an array containing
inlineremote items to be added in "Functions" menu below
breadcrumbs.
+=item * $ltiscope, optional argument, will be one of: resource, map or
+ course, if LON-CAPA is in LTI Provider context. Value is
+ the scope of use, i.e., launch was for access to a single, a map
+ or the entire course.
+
+=item * $ltiuri, optional argument, if LON-CAPA is in LTI Provider
+ context, this will contain the URL for the landing item in
+ the course, after launch from an LTI Consumer
+
+=item * $ltimenu, optional argument, if LON-CAPA is in LTI Provider
+ context, this will contain a reference to hash of items
+ to be included in the page header and/or inline menu.
+
=back
Returns: A uniform header for LON-CAPA web pages.
@@ -5808,7 +6043,7 @@ other decorations will be returned.
sub bodytag {
my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,
- $no_nav_bar,$bgcolor,$args,$advtoolsref)=@_;
+ $no_nav_bar,$bgcolor,$args,$advtoolsref,$ltiscope,$ltiuri,$ltimenu)=@_;
my $public;
if ((($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public'))
@@ -5817,6 +6052,7 @@ sub bodytag {
}
if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
my $httphost = $args->{'use_absolute'};
+ my $hostname = $args->{'hostname'};
$function = &get_users_function() if (!$function);
my $img = &designparm($function.'.img',$domain);
@@ -5844,6 +6080,14 @@ sub bodytag {
if ($env{'request.course.id'}) {
if ($env{'request.role'} !~ /^cr/) {
$role = &Apache::lonnet::plaintext($role,&course_type());
+ } elsif ($role =~ m{^cr/($match_domain)/\1-domainconfig/(\w+)$}) {
+ if ($env{'request.role.desc'}) {
+ $role = $env{'request.role.desc'};
+ } else {
+ $role = &mt('Helpdesk[_1]',' '.$2);
+ }
+ } else {
+ $role = (split(/\//,$role,4))[-1];
}
if ($env{'request.course.sec'}) {
$role .= (' 'x2).'- '.&mt('section:').' '.$env{'request.course.sec'};
@@ -5870,7 +6114,18 @@ sub bodytag {
if ($public) {
undef($role);
}
-
+
+ if (($env{'request.course.id'}) && ($env{'request.lti.login'})) {
+ if (ref($ltimenu) eq 'HASH') {
+ unless ($ltimenu->{'role'}) {
+ undef($role);
+ }
+ unless ($ltimenu->{'coursetitle'}) {
+ $realm=' ';
+ }
+ }
+ }
+
my $titleinfo = '<h1>'.$title.'</h1>';
#
# Extra info if you are the DC
@@ -5904,27 +6159,29 @@ sub bodytag {
$bodytag .= Apache::lonhtmlcommon::scripttag(
Apache::lonmenu::utilityfunctions($httphost), 'start');
- my ($left,$right) = Apache::lonmenu::primary_menu($crstype);
+ unless ($args->{'no_primary_menu'}) {
+ my ($left,$right) = Apache::lonmenu::primary_menu($crstype,$ltimenu);
- if ($env{'request.noversionuri'} =~ m{^/res/adm/pages/}) {
- if ($dc_info) {
- $dc_info = qq|<span class="LC_cusr_subheading">$dc_info</span>|;
- }
- $bodytag .= qq|<div id="LC_nav_bar">$left $role<br />
- <em>$realm</em> $dc_info</div>|;
- return $bodytag;
- }
+ if ($env{'request.noversionuri'} =~ m{^/res/adm/pages/}) {
+ if ($dc_info) {
+ $dc_info = qq|<span class="LC_cusr_subheading">$dc_info</span>|;
+ }
+ $bodytag .= qq|<div id="LC_nav_bar">$left $role<br />
+ <em>$realm</em> $dc_info</div>|;
+ return $bodytag;
+ }
- unless ($env{'request.symb'} =~ m/\.page___\d+___/) {
- $bodytag .= qq|<div id="LC_nav_bar">$left $role</div>|;
- }
+ unless ($env{'request.symb'} =~ m/\.page___\d+___/) {
+ $bodytag .= qq|<div id="LC_nav_bar">$left $role</div>|;
+ }
- $bodytag .= $right;
+ $bodytag .= $right;
- if ($dc_info) {
- $dc_info = &dc_courseid_toggle($dc_info);
+ if ($dc_info) {
+ $dc_info = &dc_courseid_toggle($dc_info);
+ }
+ $bodytag .= qq|<div id="LC_realm">$realm $dc_info</div>|;
}
- $bodytag .= qq|<div id="LC_realm">$realm $dc_info</div>|;
#if directed to not display the secondary menu, don't.
if ($args->{'no_secondary_menu'}) {
@@ -5932,21 +6189,26 @@ sub bodytag {
}
#don't show menus for public users
if (!$public){
- $bodytag .= Apache::lonmenu::secondary_menu($httphost);
+ unless ($args->{'no_inline_menu'}) {
+ $bodytag .= Apache::lonmenu::secondary_menu($httphost,$ltiscope,$ltimenu,
+ $args->{'no_primary_menu'});
+ }
$bodytag .= Apache::lonmenu::serverform();
$bodytag .= Apache::lonhtmlcommon::scripttag('', 'end');
if ($env{'request.state'} eq 'construct') {
$bodytag .= &Apache::lonmenu::innerregister($forcereg,
- $args->{'bread_crumbs'});
+ $args->{'bread_crumbs'},'','',$hostname,$ltiscope,$ltiuri);
} elsif ($forcereg) {
$bodytag .= &Apache::lonmenu::innerregister($forcereg,undef,
- $args->{'group'});
+ $args->{'group'},
+ $args->{'hide_buttons'},
+ $hostname,$ltiscope,$ltiuri);
} else {
$bodytag .=
&Apache::lonmenu::prepare_functions($env{'request.noversionuri'},
$forcereg,$args->{'group'},
$args->{'bread_crumbs'},
- $advtoolsref);
+ $advtoolsref,'',$hostname);
}
}else{
# this is to seperate menu from content when there's no secondary
@@ -6408,6 +6670,11 @@ td.LC_menubuttons_text {
background: $tabbg;
}
+td.LC_zero_height {
+ line-height: 0;
+ cellpadding: 0;
+}
+
table.LC_data_table {
border: 1px solid #000000;
border-collapse: separate;
@@ -6729,6 +6996,12 @@ td.LC_parm_overview_restrictions {
border-collapse: collapse;
}
+span.LC_parm_recursive,
+td.LC_parm_recursive {
+ font-weight: bold;
+ font-size: smaller;
+}
+
table.LC_parm_overview_restrictions td {
border-width: 1px 4px 1px 4px;
border-style: solid;
@@ -6998,7 +7271,8 @@ table.LC_prior_tries td {
padding: 6px;
}
-.LC_answer_unknown {
+.LC_answer_unknown,
+.LC_answer_warning {
background: orange;
color: black;
padding: 6px;
@@ -7080,6 +7354,12 @@ table.LC_data_table tr > td.LC_docs_entr
color: #990000;
}
+.LC_docs_alias {
+ color: #440055;
+}
+
+.LC_domprefs_email,
+.LC_docs_alias_name,
.LC_docs_reinit_warn,
.LC_docs_ext_edit {
font-size: x-small;
@@ -7988,6 +8268,14 @@ ul.LC_funclist li {
cursor:pointer;
}
+pre.LC_wordwrap {
+ white-space: pre-wrap;
+ white-space: -moz-pre-wrap;
+ white-space: -pre-wrap;
+ white-space: -o-pre-wrap;
+ word-wrap: break-word;
+}
+
/*
styles used for response display
*/
@@ -8100,6 +8388,39 @@ section.role-warning>h1:before {
content:url('/adm/daxe/images/section_icons/warning.png');
}
+#LC_minitab_header {
+ float:left;
+ width:100%;
+ background:#DAE0D2 url("/res/adm/pages/minitabmenu_bg.gif") repeat-x bottom;
+ font-size:93%;
+ line-height:normal;
+ margin: 0.5em 0 0.5em 0;
+}
+#LC_minitab_header ul {
+ margin:0;
+ padding:10px 10px 0;
+ list-style:none;
+}
+#LC_minitab_header li {
+ float:left;
+ background:url("/res/adm/pages/minitabmenu_left.gif") no-repeat left top;
+ margin:0;
+ padding:0 0 0 9px;
+}
+#LC_minitab_header a {
+ display:block;
+ background:url("/res/adm/pages/minitabmenu_right.gif") no-repeat right top;
+ padding:5px 15px 4px 6px;
+}
+#LC_minitab_header #LC_current_minitab {
+ background-image:url("/res/adm/pages/minitabmenu_left_on.gif");
+}
+#LC_minitab_header #LC_current_minitab a {
+ background-image:url("/res/adm/pages/minitabmenu_right_on.gif");
+ padding-bottom:5px;
+}
+
+
END
}
@@ -8292,6 +8613,7 @@ OFFLOAD
<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=0, minimum-scale=1.0, maximum-scale=1.0">
<meta name="apple-mobile-web-app-capable" content="yes" />';
}
+ $result .= '<meta name="google" content="notranslate" />'."\n";
return $result.'</head>';
}
@@ -8471,8 +8793,14 @@ $args - additional optional args support
no_auto_mt_title -> prevent &mt()ing the title arg
bread_crumbs -> Array containing breadcrumbs
bread_crumbs_component -> if exists show it as headline else show only the breadcrumbs
+ bread_crumbs_nomenu -> if true will pass false as the value of $menulink
+ to lonhtmlcommon::breadcrumbs
group -> includes the current group, if page is for a
- specific group
+ specific group
+ use_absolute -> for request for external resource or syllabus, this
+ will contain https://<hostname> if server uses
+ https (as per hosts.tab), but request is for http
+ hostname -> hostname, originally from $r->hostname(), (optional).
=back
@@ -8485,11 +8813,42 @@ sub start_page {
#&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
$env{'internal.start_page'}++;
- my ($result,@advtools);
+ my ($result,@advtools,$ltiscope,$ltiuri,%ltimenu);
if (! exists($args->{'skip_phases'}{'head'}) ) {
$result .= &xml_begin($args->{'frameset'}) . &headtag($title, $head_extra, $args);
}
+
+ if (($env{'request.course.id'}) && ($env{'request.lti.login'})) {
+ if ($env{'course.'.$env{'request.course.id'}.'.lti.override'}) {
+ unless ($env{'course.'.$env{'request.course.id'}.'.lti.topmenu'}) {
+ $args->{'no_primary_menu'} = 1;
+ }
+ unless ($env{'course.'.$env{'request.course.id'}.'.lti.inlinemenu'}) {
+ $args->{'no_inline_menu'} = 1;
+ }
+ if ($env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'}) {
+ map { $ltimenu{$_} = 1; } split(/,/,$env{'course.'.$env{'request.course.id'}.'.lti.lcmenu'});
+ }
+ } else {
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my %lti = &Apache::lonnet::get_domain_lti($cdom,'provider');
+ if (ref($lti{$env{'request.lti.login'}}) eq 'HASH') {
+ unless ($lti{$env{'request.lti.login'}}{'topmenu'}) {
+ $args->{'no_primary_menu'} = 1;
+ }
+ unless ($lti{$env{'request.lti.login'}}{'inlinemenu'}) {
+ $args->{'no_inline_menu'} = 1;
+ }
+ if (ref($lti{$env{'request.lti.login'}}{'lcmenu'}) eq 'ARRAY') {
+ map { $ltimenu{$_} = 1; } @{$lti{$env{'request.lti.login'}}{'lcmenu'}};
+ }
+ }
+ }
+ ($ltiscope,$ltiuri) = &LONCAPA::ltiutils::lti_provider_scope($env{'request.lti.uri'},
+ $env{'course.'.$env{'request.course.id'}.'.domain'},
+ $env{'course.'.$env{'request.course.id'}.'.num'});
+ }
if (! exists($args->{'skip_phases'}{'body'}) ) {
if ($args->{'frameset'}) {
@@ -8503,7 +8862,7 @@ sub start_page {
$args->{'only_body'}, $args->{'domain'},
$args->{'force_register'}, $args->{'no_nav_bar'},
$args->{'bgcolor'}, $args,
- \@advtools);
+ \@advtools,$ltiscope,$ltiuri,\%ltimenu);
}
}
@@ -8536,15 +8895,22 @@ sub start_page {
if (@advtools > 0) {
&Apache::lonmenu::advtools_crumbs(@advtools);
}
-
+ my $menulink;
+ # if arg: bread_crumbs_nomenu is true pass 0 as $menulink item.
+ if ((exists($args->{'bread_crumbs_nomenu'})) ||
+ ($ltiscope eq 'map') || ($ltiscope eq 'resource') ||
+ ((($args->{'crstype'} eq 'Placement') || (($env{'request.course.id'}) &&
+ ($env{'course.'.$env{'request.course.id'}.'.type'} eq 'Placement'))) &&
+ (!$env{'request.role.adv'}))) {
+ $menulink = 0;
+ } else {
+ undef($menulink);
+ }
#if bread_crumbs_component exists show it as headline else show only the breadcrumbs
if(exists($args->{'bread_crumbs_component'})){
- $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'});
- } elsif ($args->{'crstype'} eq 'Placement') {
- $result .= &Apache::lonhtmlcommon::breadcrumbs('','','','','','','','','',
- $args->{'crstype'});
+ $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'},'',$menulink);
} else {
- $result .= &Apache::lonhtmlcommon::breadcrumbs();
+ $result .= &Apache::lonhtmlcommon::breadcrumbs('','',$menulink);
}
}
return $result;
@@ -8641,7 +9007,7 @@ var modalWindow = {
};
var openMyModal = function(source,width,height,scrolling,transparency,style)
{
- source = source.replace("'","'");
+ source = source.replace(/'/g,"'");
modalWindow.windowId = "myModal";
modalWindow.width = width;
modalWindow.height = height;
@@ -8666,8 +9032,7 @@ sub modal_link {
$target_attr = 'target="'.$target.'"';
}
return <<"ENDLINK";
-<a href="$link" $target_attr title="$title" onclick="javascript:openMyModal('$link',$width,$height,'$scrolling','$transparency','$style'); return false;">
- $linktext</a>
+<a href="$link" $target_attr title="$title" onclick="javascript:openMyModal('$link',$width,$height,'$scrolling','$transparency','$style'); return false;">$linktext</a>
ENDLINK
}
@@ -8770,8 +9135,9 @@ sub end_togglebox {
}
sub LCprogressbar_script {
- my ($id)=@_;
- return(<<ENDPROGRESS);
+ my ($id,$number_to_do)=@_;
+ if ($number_to_do) {
+ return(<<ENDPROGRESS);
<script type="text/javascript">
// <![CDATA[
\$('#progressbar$id').progressbar({
@@ -8784,21 +9150,43 @@ sub LCprogressbar_script {
// ]]>
</script>
ENDPROGRESS
+ } else {
+ return(<<ENDPROGRESS);
+<script type="text/javascript">
+// <![CDATA[
+\$('#progressbar$id').progressbar({
+ value: false,
+ create: function(event, ui) {
+ \$('.ui-widget-header', this).css({'background':'#F0F0F0'});
+ \$('.ui-progressbar-overlay', this).css({'margin':'0'});
+ }
+});
+// ]]>
+</script>
+ENDPROGRESS
+ }
}
sub LCprogressbarUpdate_script {
return(<<ENDPROGRESSUPDATE);
<style type="text/css">
.ui-progressbar { position:relative; }
+.progress-label {position: absolute; width: 100%; text-align: center; top: 1px; font-weight: bold; text-shadow: 1px 1px 0 #fff;margin: 0; line-height: 200%; }
.pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; }
</style>
<script type="text/javascript">
// <![CDATA[
var LCprogressTxt='---';
-function LCupdateProgress(percent,progresstext,id) {
+function LCupdateProgress(percent,progresstext,id,maxnum) {
LCprogressTxt=progresstext;
- \$('#progressbar'+id).progressbar('value',percent);
+ if ((maxnum == '') || (maxnum == undefined) || (maxnum == null)) {
+ \$('#progressbar'+id).find('.progress-label').text(LCprogressTxt);
+ } else if (percent === \$('#progressbar'+id).progressbar( "value" )) {
+ \$('#progressbar'+id).find('.pblabel').text(LCprogressTxt);
+ } else {
+ \$('#progressbar'+id).progressbar('value',percent);
+ }
}
// ]]>
</script>
@@ -8810,37 +9198,54 @@ my $LCidcnt;
my $LCcurrentid;
sub LCprogressbar {
- my ($r)=(@_);
+ my ($r,$number_to_do,$preamble)=@_;
$LClastpercent=0;
$LCidcnt++;
$LCcurrentid=$$.'_'.$LCidcnt;
- my $starting=&mt('Starting');
- my $content=(<<ENDPROGBAR);
+ my ($starting,$content);
+ if ($number_to_do) {
+ $starting=&mt('Starting');
+ $content=(<<ENDPROGBAR);
+$preamble
<div id="progressbar$LCcurrentid">
<span class="pblabel">$starting</span>
</div>
ENDPROGBAR
- &r_print($r,$content.&LCprogressbar_script($LCcurrentid));
+ } else {
+ $starting=&mt('Loading...');
+ $LClastpercent='false';
+ $content=(<<ENDPROGBAR);
+$preamble
+ <div id="progressbar$LCcurrentid">
+ <div class="progress-label">$starting</div>
+ </div>
+ENDPROGBAR
+ }
+ &r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do));
}
sub LCprogressbarUpdate {
- my ($r,$val,$text)=@_;
- unless ($val) {
- if ($LClastpercent) {
- $val=$LClastpercent;
- } else {
- $val=0;
- }
+ my ($r,$val,$text,$number_to_do)=@_;
+ if ($number_to_do) {
+ unless ($val) {
+ if ($LClastpercent) {
+ $val=$LClastpercent;
+ } else {
+ $val=0;
+ }
+ }
+ if ($val<0) { $val=0; }
+ if ($val>100) { $val=0; }
+ $LClastpercent=$val;
+ unless ($text) { $text=$val.'%'; }
+ } else {
+ $val = 'false';
}
- if ($val<0) { $val=0; }
- if ($val>100) { $val=0; }
- $LClastpercent=$val;
- unless ($text) { $text=$val.'%'; }
$text=&js_ready($text);
&r_print($r,<<ENDUPDATE);
<script type="text/javascript">
// <![CDATA[
-LCupdateProgress($val,'$text','$LCcurrentid');
+LCupdateProgress($val,'$text','$LCcurrentid','$number_to_do');
// ]]>
</script>
ENDUPDATE
@@ -9025,14 +9430,21 @@ function expand_div(caller) {
sub simple_error_page {
my ($r,$title,$msg,$args) = @_;
+ my %displayargs;
if (ref($args) eq 'HASH') {
if (!$args->{'no_auto_mt_msg'}) { $msg = &mt($msg); }
+ if ($args->{'only_body'}) {
+ $displayargs{'only_body'} = 1;
+ }
+ if ($args->{'no_nav_bar'}) {
+ $displayargs{'no_nav_bar'} = 1;
+ }
} else {
$msg = &mt($msg);
}
my $page =
- &Apache::loncommon::start_page($title).
+ &Apache::loncommon::start_page($title,'',\%displayargs).
'<p class="LC_error">'.$msg.'</p>'.
&Apache::loncommon::end_page();
if (ref($r)) {
@@ -9960,7 +10372,7 @@ sub get_secgrprole_info {
}
sub user_picker {
- my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context) = @_;
+ my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom,$noinstd) = @_;
my $currdom = $dom;
my @alldoms = &Apache::lonnet::all_domains();
if (@alldoms == 1) {
@@ -10024,7 +10436,23 @@ sub user_picker {
);
&html_escape(\%html_lt);
&js_escape(\%js_lt);
- my $domform = &select_dom_form($currdom,'srchdomain',1,1);
+ my $domform;
+ my $allow_blank = 1;
+ if ($fixeddom) {
+ $allow_blank = 0;
+ $domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,[$currdom]);
+ } else {
+ my $defdom = $env{'request.role.domain'};
+ my ($trusted,$untrusted);
+ if (($context eq 'requestcrs') || ($context eq 'course')) {
+ ($trusted,$untrusted) = &Apache::lonnet::trusted_domains('enroll',$defdom);
+ } elsif ($context eq 'author') {
+ ($trusted,$untrusted) = &Apache::lonnet::trusted_domains('othcoau',$defdom);
+ } elsif ($context eq 'domain') {
+ ($trusted,$untrusted) = &Apache::lonnet::trusted_domains('domroles',$defdom);
+ }
+ $domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,$trusted,$untrusted);
+ }
my $srchinsel = ' <select name="srchin">';
my @srchins = ('crs','dom','alc','instd');
@@ -10036,6 +10464,7 @@ sub user_picker {
next if ($option eq 'alc');
next if (($option eq 'crs') && ($env{'form.form'} eq 'requestcrs'));
next if ($option eq 'crs' && !$env{'request.course.id'});
+ next if (($option eq 'instd') && ($noinstd));
if ($curr_selected{'srchin'} eq $option) {
$srchinsel .= '
<option value="'.$option.'" selected="selected">'.$html_lt{$option}.'</option>';
@@ -10533,7 +10962,7 @@ sub get_institutional_codes {
foreach (@currxlists) {
if (m/^([^:]+):(\w*)$/) {
unless (grep/^$1$/,@{$allcourses}) {
- push @{$allcourses},$1;
+ push(@{$allcourses},$1);
$$LC_code{$1} = $2;
}
}
@@ -10546,7 +10975,7 @@ sub get_institutional_codes {
my $sec = $coursecode.$1;
my $lc_sec = $2;
unless (grep/^$sec$/,@{$allcourses}) {
- push @{$allcourses},$sec;
+ push(@{$allcourses},$sec);
$$LC_code{$sec} = $lc_sec;
}
}
@@ -11874,7 +12303,7 @@ sub modify_html_refs {
return;
}
}
- if (open(my $fh,"<$container")) {
+ if (open(my $fh,'<',$container)) {
$content = join('', <$fh>);
close($fh);
} else {
@@ -11939,7 +12368,7 @@ sub modify_html_refs {
}
}
} else {
- if (open(my $fh,">$container")) {
+ if (open(my $fh,'>',$container)) {
print $fh $content;
close($fh);
$output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].',
@@ -12456,6 +12885,18 @@ sub decompress_uploaded_file {
sub process_decompression {
my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_;
+ unless (($dir_root eq '/userfiles') && ($destination =~ m{^(docs|supplemental)/(default|\d+)/\d+$})) {
+ return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
+ &mt('Unexpected file path.').'</p>'."\n";
+ }
+ unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) {
+ return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
+ &mt('Unexpected course context.').'</p>'."\n";
+ }
+ unless ($file eq &Apache::lonnet::clean_filename($file)) {
+ return '<p class="LC_error">'.&mt('Not extracted.').'<br />'.
+ &mt('Filename contained unexpected characters.').'</p>'."\n";
+ }
my ($dir,$error,$warning,$output);
if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) {
$error = &mt('Filename not a supported archive file type.').
@@ -12490,30 +12931,44 @@ sub process_decompression {
}
}
my $numskip = scalar(@to_skip);
- if (($numskip > 0) &&
- ($numskip == $env{'form.archive_itemcount'})) {
+ my $numoverwrite = scalar(@to_overwrite);
+ if (($numskip) && (!$numoverwrite)) {
$warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.');
} elsif ($dir eq '') {
$error = &mt('Directory containing archive file unavailable.');
} elsif (!$error) {
my ($decompressed,$display);
- if ($numskip > 0) {
+ if (($numskip) || ($numoverwrite)) {
my $tempdir = time.'_'.$$.int(rand(10000));
mkdir("$dir/$tempdir",0755);
- system("mv $dir/$file $dir/$tempdir/$file");
- ($decompressed,$display) =
- &decompress_uploaded_file($file,"$dir/$tempdir");
- foreach my $item (@to_skip) {
- if (($item ne '') && ($item !~ /\.\./)) {
- if (-f "$dir/$tempdir/$item") {
- unlink("$dir/$tempdir/$item");
- } elsif (-d "$dir/$tempdir/$item") {
- system("rm -rf $dir/$tempdir/$item");
+ if (&File::Copy::move("$dir/$file","$dir/$tempdir/$file")) {
+ ($decompressed,$display) =
+ &decompress_uploaded_file($file,"$dir/$tempdir");
+ foreach my $item (@to_skip) {
+ if (($item ne '') && ($item !~ /\.\./)) {
+ if (-f "$dir/$tempdir/$item") {
+ unlink("$dir/$tempdir/$item");
+ } elsif (-d "$dir/$tempdir/$item") {
+ &File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 });
+ }
+ }
+ }
+ foreach my $item (@to_overwrite) {
+ if ((-e "$dir/$tempdir/$item") && (-e "$dir/$item")) {
+ if (($item ne '') && ($item !~ /\.\./)) {
+ if (-f "$dir/$item") {
+ unlink("$dir/$item");
+ } elsif (-d "$dir/$item") {
+ &File::Path::remove_tree("$dir/$item",{ safe => 1 });
+ }
+ &File::Copy::move("$dir/$tempdir/$item","$dir/$item");
+ }
}
}
+ if (&File::Copy::move("$dir/$tempdir/$file","$dir/$file")) {
+ &File::Path::remove_tree("$dir/$tempdir",{ safe => 1 });
+ }
}
- system("mv $dir/$tempdir/* $dir");
- rmdir("$dir/$tempdir");
} else {
($decompressed,$display) =
&decompress_uploaded_file($file,$dir);
@@ -12531,8 +12986,7 @@ sub process_decompression {
if (ref($newdirlistref) eq 'ARRAY') {
foreach my $dir_line (@{$newdirlistref}) {
my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5);
- unless (($item =~ /^\.+$/) || ($item eq $file) ||
- ((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) {
+ unless (($item =~ /^\.+$/) || ($item eq $file)) {
push(@newitems,$item);
if ($dirptr&$testdir) {
$is_dir{$item} = 1;
@@ -13017,7 +13471,7 @@ END
sub process_extracted_files {
my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_;
my $numitems = $env{'form.archive_count'};
- return unless ($numitems);
+ return if ((!$numitems) || ($numitems =~ /\D/));
my @ids=&Apache::lonnet::current_machine_ids();
my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir,
%folders,%containers,%mapinner,%prompttofetch);
@@ -13030,7 +13484,7 @@ sub process_extracted_files {
} else {
$prefix = $Apache::lonnet::perlvar{'lonDocRoot'};
$pathtocheck = "$dir_root/$docudom/$docuname/$destination";
- $dir = "$dir_root/$docudom/$docuname";
+ $dir = "$dir_root/$docudom/$docuname";
}
my $currdir = "$dir_root/$destination";
(my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/});
@@ -13119,7 +13573,9 @@ sub process_extracted_files {
'.'.$containers{$outer},1,1);
$newseqid{$i} = $newidx;
unless ($errtext) {
- $result .= '<li>'.&mt('Folder: [_1] added to course',$docstitle).'</li>'."\n";
+ $result .= '<li>'.&mt('Folder: [_1] added to course',
+ &HTML::Entities::encode($docstitle,'<>&"')).
+ '</li>'."\n";
}
}
} else {
@@ -13128,38 +13584,47 @@ sub process_extracted_files {
my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.
$docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.
$title;
- if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
- mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
- }
- if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
- mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
- }
- if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
- system("mv $prefix$path $prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title");
- $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
- unless ($ishome) {
- my $fetch = "$newdest{$i}/$title";
- $fetch =~ s/^\Q$prefix$dir\E//;
- $prompttofetch{$fetch} = 1;
+ if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) {
+ if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
+ mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
}
- }
- $LONCAPA::map::resources[$newidx]=
- $docstitle.':'.$url.':false:normal:res';
- push(@LONCAPA::map::order, $newidx);
- my ($outtext,$errtext)=
- &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
- $docuname.'/'.$folders{$outer}.
- '.'.$containers{$outer},1,1);
- unless ($errtext) {
- if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
- $result .= '<li>'.&mt('File: [_1] added to course',$docstitle).'</li>'."\n";
+ if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
+ mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
+ }
+ if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
+ if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) {
+ $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
+ unless ($ishome) {
+ my $fetch = "$newdest{$i}/$title";
+ $fetch =~ s/^\Q$prefix$dir\E//;
+ $prompttofetch{$fetch} = 1;
+ }
+ }
+ }
+ $LONCAPA::map::resources[$newidx]=
+ $docstitle.':'.$url.':false:normal:res';
+ push(@LONCAPA::map::order, $newidx);
+ my ($outtext,$errtext)=
+ &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
+ $docuname.'/'.$folders{$outer}.
+ '.'.$containers{$outer},1,1);
+ unless ($errtext) {
+ if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
+ $result .= '<li>'.&mt('File: [_1] added to course',
+ &HTML::Entities::encode($docstitle,'<>&"')).
+ '</li>'."\n";
+ }
}
+ } else {
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path,'<>&"')).'<br />';
}
}
}
}
} else {
- $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />';
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path,'<>&"')).'<br />';
}
}
for (my $i=1; $i<=$numitems; $i++) {
@@ -13220,7 +13685,9 @@ sub process_extracted_files {
}
if ($fullpath ne '') {
if (-e "$prefix$path") {
- system("mv $prefix$path $fullpath/$title");
+ unless (rename("$prefix$path","$fullpath/$title")) {
+ $warning .= &mt('Failed to rename dependency').'<br />';
+ }
}
if (-e "$fullpath/$title") {
my $showpath;
@@ -13229,21 +13696,26 @@ sub process_extracted_files {
} else {
$showpath = "/$title";
}
- $result .= '<li>'.&mt('[_1] included as a dependency',$showpath).'</li>'."\n";
- }
- unless ($ishome) {
- my $fetch = "$fullpath/$title";
- $fetch =~ s/^\Q$prefix$dir\E//;
- $prompttofetch{$fetch} = 1;
+ $result .= '<li>'.&mt('[_1] included as a dependency',
+ &HTML::Entities::encode($showpath,'<>&"')).
+ '</li>'."\n";
+ unless ($ishome) {
+ my $fetch = "$fullpath/$title";
+ $fetch =~ s/^\Q$prefix$dir\E//;
+ $prompttofetch{$fetch} = 1;
+ }
}
}
}
} elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {
$warning .= &mt('[_1] is a dependency of [_2], which was discarded.',
- $path,$env{'form.archive_content_'.$referrer{$i}}).'<br />';
+ &HTML::Entities::encode($path,'<>&"'),
+ &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')).
+ '<br />';
}
} else {
- $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />';
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path)).'<br />';
}
}
if (keys(%todelete)) {
@@ -13517,12 +13989,15 @@ sub upfile_store {
$env{'form.upfile'}=~s/\n+/\n/gs;
$env{'form.upfile'}=~s/\n+$//gs;
- my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
- '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
+ my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.
+ '_enroll_'.$env{'request.course.id'}.'_'.
+ time.'_'.$$);
+ return if ($datatoken eq '');
+
{
my $datafile = $r->dir_config('lonDaemons').
'/tmp/'.$datatoken.'.tmp';
- if ( open(my $fh,">$datafile") ) {
+ if ( open(my $fh,'>',$datafile) ) {
print $fh $env{'form.upfile'};
close($fh);
}
@@ -13532,21 +14007,22 @@ sub upfile_store {
=pod
-=item * &load_tmp_file($r)
+=item * &load_tmp_file($r,$datatoken)
Load uploaded file from tmp, $r should be the HTTP Request object,
-needs $env{'form.datatoken'},
+$datatoken is the name to assign to the temporary file.
sets $env{'form.upfile'} to the contents of the file
=cut
sub load_tmp_file {
- my $r=shift;
+ my ($r,$datatoken) = @_;
+ return if ($datatoken eq '');
my @studentdata=();
{
my $studentfile = $r->dir_config('lonDaemons').
- '/tmp/'.$env{'form.datatoken'}.'.tmp';
- if ( open(my $fh,"<$studentfile") ) {
+ '/tmp/'.$datatoken.'.tmp';
+ if ( open(my $fh,'<',$studentfile) ) {
@studentdata=<$fh>;
close($fh);
}
@@ -13554,6 +14030,14 @@ sub load_tmp_file {
$env{'form.upfile'}=join('',@studentdata);
}
+sub valid_datatoken {
+ my ($datatoken) = @_;
+ if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) {
+ return $datatoken;
+ }
+ return;
+}
+
=pod
=item * &upfile_record_sep()
@@ -13994,7 +14478,7 @@ sub DrawBarGraph {
@Labels = @$labels;
} else {
for (my $i=0;$i<@{$Values[0]};$i++) {
- push (@Labels,$i+1);
+ push(@Labels,$i+1);
}
}
#
@@ -14440,7 +14924,14 @@ requestsmail, updatesmail, or idconflict
defdom (domain for which to retrieve configuration settings),
origmail (scalar - email address of recipient from loncapa.conf,
-i.e., predates configuration by DC via domainprefs.pm
+i.e., predates configuration by DC via domainprefs.pm
+
+$requname username of requester (if mailing type is helpdeskmail)
+
+$requdom domain of requester (if mailing type is helpdeskmail)
+
+$reqemail e-mail address of requester (if mailing type is helpdeskmail)
+
Returns: comma separated list of addresses to which to send e-mail.
@@ -14451,11 +14942,11 @@ Returns: comma separated list of address
############################################################
############################################################
sub build_recipient_list {
- my ($defmail,$mailing,$defdom,$origmail) = @_;
+ my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_;
my @recipients;
- my $otheremails;
+ my ($otheremails,$lastresort,$allbcc,$addtext);
my %domconfig =
- &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
+ &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
if (ref($domconfig{'contacts'}) eq 'HASH') {
if (exists($domconfig{'contacts'}{$mailing})) {
if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
@@ -14467,14 +14958,183 @@ sub build_recipient_list {
push(@recipients,$addr);
}
}
- $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
+ }
+ $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
+ if ($mailing eq 'helpdeskmail') {
+ if ($domconfig{'contacts'}{$mailing}{'bcc'}) {
+ my @bccs = split(/,/,$domconfig{'contacts'}{$mailing}{'bcc'});
+ my @ok_bccs;
+ foreach my $bcc (@bccs) {
+ $bcc =~ s/^\s+//g;
+ $bcc =~ s/\s+$//g;
+ if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
+ if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
+ push(@ok_bccs,$bcc);
+ }
+ }
+ }
+ if (@ok_bccs > 0) {
+ $allbcc = join(', ',@ok_bccs);
+ }
+ }
+ $addtext = $domconfig{'contacts'}{$mailing}{'include'};
}
}
} elsif ($origmail ne '') {
- push(@recipients,$origmail);
+ $lastresort = $origmail;
+ }
+ if ($mailing eq 'helpdeskmail') {
+ if ((ref($domconfig{'contacts'}{'overrides'}) eq 'HASH') &&
+ (keys(%{$domconfig{'contacts'}{'overrides'}}))) {
+ my ($inststatus,$inststatus_checked);
+ if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
+ ($env{'user.domain'} ne 'public')) {
+ $inststatus_checked = 1;
+ $inststatus = $env{'environment.inststatus'};
+ }
+ unless ($inststatus_checked) {
+ if (($requname ne '') && ($requdom ne '')) {
+ if (($requname =~ /^$match_username$/) &&
+ ($requdom =~ /^$match_domain$/) &&
+ (&Apache::lonnet::domain($requdom))) {
+ my $requhome = &Apache::lonnet::homeserver($requname,
+ $requdom);
+ unless ($requhome eq 'no_host') {
+ my %userenv = &Apache::lonnet::userenvironment($requdom,$requname,'inststatus');
+ $inststatus = $userenv{'inststatus'};
+ $inststatus_checked = 1;
+ }
+ }
+ }
+ }
+ unless ($inststatus_checked) {
+ if ($reqemail =~ /^[^\@]+\@[^\@]+$/) {
+ my %srch = (srchby => 'email',
+ srchdomain => $defdom,
+ srchterm => $reqemail,
+ srchtype => 'exact');
+ my %srch_results = &Apache::lonnet::usersearch(\%srch);
+ foreach my $uname (keys(%srch_results)) {
+ if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
+ $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
+ $inststatus_checked = 1;
+ last;
+ }
+ }
+ unless ($inststatus_checked) {
+ my ($dirsrchres,%srch_results) = &Apache::lonnet::inst_directory_query(\%srch);
+ if ($dirsrchres eq 'ok') {
+ foreach my $uname (keys(%srch_results)) {
+ if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
+ $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
+ $inststatus_checked = 1;
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ if ($inststatus ne '') {
+ foreach my $status (split(/\:/,$inststatus)) {
+ if (ref($domconfig{'contacts'}{'overrides'}{$status}) eq 'HASH') {
+ my @contacts = ('adminemail','supportemail');
+ foreach my $item (@contacts) {
+ if ($domconfig{'contacts'}{'overrides'}{$status}{$item}) {
+ my $addr = $domconfig{'contacts'}{'overrides'}{$status};
+ if (!grep(/^\Q$addr\E$/,@recipients)) {
+ push(@recipients,$addr);
+ }
+ }
+ }
+ $otheremails = $domconfig{'contacts'}{'overrides'}{$status}{'others'};
+ if ($domconfig{'contacts'}{'overrides'}{$status}{'bcc'}) {
+ my @bccs = split(/,/,$domconfig{'contacts'}{'overrides'}{$status}{'bcc'});
+ my @ok_bccs;
+ foreach my $bcc (@bccs) {
+ $bcc =~ s/^\s+//g;
+ $bcc =~ s/\s+$//g;
+ if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
+ if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
+ push(@ok_bccs,$bcc);
+ }
+ }
+ }
+ if (@ok_bccs > 0) {
+ $allbcc = join(', ',@ok_bccs);
+ }
+ }
+ $addtext = $domconfig{'contacts'}{'overrides'}{$status}{'include'};
+ last;
+ }
+ }
+ }
+ }
}
} elsif ($origmail ne '') {
- push(@recipients,$origmail);
+ $lastresort = $origmail;
+ }
+ if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) {
+ unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {
+ my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
+ my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'};
+ my %what = (
+ perlvar => 1,
+ );
+ my $primary = &Apache::lonnet::domain($defdom,'primary');
+ if ($primary) {
+ my $gotaddr;
+ my ($result,$returnhash) =
+ &Apache::lonnet::get_remote_globals($primary,{ perlvar => 1 });
+ if (($result eq 'ok') && (ref($returnhash) eq 'HASH')) {
+ if ($returnhash->{'lonSupportEMail'} =~ /^[^\@]+\@[^\@]+$/) {
+ $lastresort = $returnhash->{'lonSupportEMail'};
+ $gotaddr = 1;
+ }
+ }
+ unless ($gotaddr) {
+ my $uintdom = &Apache::lonnet::internet_dom($primary);
+ my $intdom = &Apache::lonnet::internet_dom($lonhost);
+ unless ($uintdom eq $intdom) {
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['contacts'],$machinedom);
+ if (ref($domconfig{'contacts'}) eq 'HASH') {
+ if (ref($domconfig{'contacts'}{'otherdomsmail'}) eq 'HASH') {
+ my @contacts = ('adminemail','supportemail');
+ foreach my $item (@contacts) {
+ if ($domconfig{'contacts'}{'otherdomsmail'}{$item}) {
+ my $addr = $domconfig{'contacts'}{$item};
+ if (!grep(/^\Q$addr\E$/,@recipients)) {
+ push(@recipients,$addr);
+ }
+ }
+ }
+ if ($domconfig{'contacts'}{'otherdomsmail'}{'others'}) {
+ $otheremails = $domconfig{'contacts'}{'otherdomsmail'}{'others'};
+ }
+ if ($domconfig{'contacts'}{'otherdomsmail'}{'bcc'}) {
+ my @bccs = split(/,/,$domconfig{'contacts'}{'otherdomsmail'}{'bcc'});
+ my @ok_bccs;
+ foreach my $bcc (@bccs) {
+ $bcc =~ s/^\s+//g;
+ $bcc =~ s/\s+$//g;
+ if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
+ if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
+ push(@ok_bccs,$bcc);
+ }
+ }
+ }
+ if (@ok_bccs > 0) {
+ $allbcc = join(', ',@ok_bccs);
+ }
+ }
+ $addtext = $domconfig{'contacts'}{'otherdomsmail'}{'include'};
+ }
+ }
+ }
+ }
+ }
+ }
}
if (defined($defmail)) {
if ($defmail ne '') {
@@ -14494,8 +15154,21 @@ sub build_recipient_list {
}
}
}
- my $recipientlist = join(',',@recipients);
- return $recipientlist;
+ if ($mailing eq 'helpdeskmail') {
+ if ((!@recipients) && ($lastresort ne '')) {
+ push(@recipients,$lastresort);
+ }
+ } elsif ($lastresort ne '') {
+ if (!grep(/^\Q$lastresort\E$/,@recipients)) {
+ push(@recipients,$lastresort);
+ }
+ }
+ my $recipientlist = join(',',@recipients);
+ if (wantarray) {
+ return ($recipientlist,$allbcc,$addtext);
+ } else {
+ return $recipientlist;
+ }
}
############################################################
@@ -14667,6 +15340,8 @@ jsarray (reference to array of categorie
subcats (reference to hash of arrays containing all subcategories within each
category, -recursive)
+maxd (reference to hash used to hold max depth for all top-level categories).
+
Returns: nothing
Side effects: populates trails and allitems hash references.
@@ -14674,7 +15349,7 @@ Side effects: populates trails and allit
=cut
sub extract_categories {
- my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;
+ my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_;
if (ref($categories) eq 'HASH') {
&gather_categories($categories,$cats,$idx,$jsarray);
if (ref($cats->[0]) eq 'ARRAY') {
@@ -14702,12 +15377,15 @@ sub extract_categories {
if (ref($subcats) eq 'HASH') {
push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
}
- &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);
+ &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd);
}
} else {
if (ref($subcats) eq 'HASH') {
$subcats->{$item} = [];
}
+ if (ref($maxd) eq 'HASH') {
+ $maxd->{$name} = 1;
+ }
}
}
}
@@ -14745,13 +15423,13 @@ Side effects: populates trails and allit
=cut
sub recurse_categories {
- my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;
+ my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_;
my $shallower = $depth - 1;
if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
my $name = $cats->[$depth]{$category}[$k];
my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
- my $trailstr = join(' -> ',(@{$parents},$category));
+ my $trailstr = join(' » ',(@{$parents},$category));
if ($allitems->{$item} eq '') {
push(@{$trails},$trailstr);
$allitems->{$item} = scalar(@{$trails})-1;
@@ -14772,16 +15450,21 @@ sub recurse_categories {
}
}
&recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
- $subcats);
+ $subcats,$maxd);
pop(@{$parents});
}
} else {
my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
- my $trailstr = join(' -> ',(@{$parents},$category));
+ my $trailstr = join(' » ',(@{$parents},$category));
if ($allitems->{$item} eq '') {
push(@{$trails},$trailstr);
$allitems->{$item} = scalar(@{$trails})-1;
}
+ if (ref($maxd) eq 'HASH') {
+ if ($depth > $maxd->{$parents->[0]}) {
+ $maxd->{$parents->[0]} = $depth;
+ }
+ }
}
return;
}
@@ -14802,16 +15485,19 @@ currcat - scalar with an & separated lis
type - scalar contains course type (Course or Community).
+disabled - scalar (optional) contains disabled="disabled" if input elements are
+ to be readonly (e.g., Domain Helpdesk role viewing course settings).
+
Returns: $output (markup to be displayed)
=cut
sub assign_categories_table {
- my ($cathash,$currcat,$type) = @_;
+ my ($cathash,$currcat,$type,$disabled) = @_;
my $output;
if (ref($cathash) eq 'HASH') {
- my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
- &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);
+ my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth);
+ &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd);
$maxdepth = scalar(@cats);
if (@cats > 0) {
my $itemcount = 0;
@@ -14847,11 +15533,11 @@ sub assign_categories_table {
}
$table .= '<tr '.$css_class.'><td><span class="LC_nobreak">'.
'<input type="checkbox" name="usecategory" value="'.
- $item.'"'.$checked.' />'.$parent_title.'</span>'.
+ $item.'"'.$checked.$disabled.' />'.$parent_title.'</span>'.
'<input type="hidden" name="catname" value="'.$parent.'" /></td>';
my $depth = 1;
push(@path,$parent);
- $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);
+ $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories,$disabled);
pop(@path);
$table .= '</tr><tr><td colspan="'.$maxdepth.'" class="LC_row_separator"></td></tr>';
$itemcount ++;
@@ -14890,12 +15576,15 @@ path - Array containing all categories b
currcategories - reference to array of current categories assigned to the course
+disabled - scalar (optional) contains disabled="disabled" if input elements are
+ to be readonly (e.g., Domain Helpdesk role viewing course settings).
+
Returns: $output (markup to be displayed).
=cut
sub assign_category_rows {
- my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_;
+ my ($itemcount,$cats,$depth,$parent,$path,$currcategories,$disabled) = @_;
my ($text,$name,$item,$chgstr);
if (ref($cats) eq 'ARRAY') {
my $maxdepth = scalar(@{$cats});
@@ -14918,12 +15607,12 @@ sub assign_category_rows {
}
$text .= '<tr><td><span class="LC_nobreak"><label>'.
'<input type="checkbox" name="usecategory" value="'.
- $item.'"'.$checked.' />'.$name.'</label></span>'.
+ $item.'"'.$checked.$disabled.' />'.$name.'</label></span>'.
'<input type="hidden" name="catname" value="'.$name.'" />'.
'</td><td>';
if (ref($path) eq 'ARRAY') {
push(@{$path},$name);
- $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories);
+ $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories,$disabled);
pop(@{$path});
}
$text .= '</td></tr>';
@@ -15150,11 +15839,11 @@ sub check_clone {
my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
if ($args->{'crstype'} eq 'Community') {
if ($clonedesc{'type'} ne 'Community') {
- $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'});
+ $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'}) &&
+ if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&
(&Apache::lonnet::allowed('ccc',$env{'request.role.domain'}))) {
$can_clone = 1;
} else {
@@ -15251,7 +15940,8 @@ sub check_clone {
}
sub construct_course {
- my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,$cnum,$category,$coderef) = @_;
+ my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
+ $cnum,$category,$coderef) = @_;
my $outcome;
my $linefeed = '<br />'."\n";
if ($context eq 'auto') {
@@ -15404,7 +16094,7 @@ sub construct_course {
my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
$cenv{'internal.sectionnums'} .= $item.',';
unless ($addcheck eq 'ok') {
- push @badclasses, $class;
+ push(@badclasses,$class);
}
}
$cenv{'internal.sectionnums'} =~ s/,$//;
@@ -15432,7 +16122,7 @@ sub construct_course {
my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
$cenv{'internal.crosslistings'} .= $item.',';
unless ($addcheck eq 'ok') {
- push @badclasses, $xl;
+ push(@badclasses,$xl);
}
}
$cenv{'internal.crosslistings'} =~ s/,$//;
@@ -15467,27 +16157,28 @@ sub construct_course {
}
if (@badclasses > 0) {
my %lt=&Apache::lonlocal::texthash(
- 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course. However, if automated course roster updates are enabled for this class, these particular sections/crosslistings will not contribute towards enrollment, because the user identified as the course owner for this LON-CAPA course',
- 'dnhr' => 'does not have rights to access enrollment in these classes',
- 'adby' => 'as determined by the policies of your institution on access to official classlists'
+ 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course.',
+ 'howi' => 'However, if automated course roster updates are enabled for this class, these particular sections/crosslistings are not guaranteed to contribute towards enrollment.',
+ 'itis' => 'It is possible that rights to access enrollment for these classes will be available through assignment of co-owners.',
);
- my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
- ' ('.$lt{'adby'}.')';
+ my $badclass_msg = $lt{'tclb'}.$linefeed.$lt{'howi'}.$linefeed.
+ &mt('That is because the user identified as the course owner ([_1]) does not have rights to access enrollment in these classes, as determined by the policies of your institution on access to official classlists',$cenv{'internal.courseowner'}).$linefeed.$lt{'itis'};
if ($context eq 'auto') {
$outcome .= $badclass_msg.$linefeed;
+ } else {
$outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
- foreach my $item (@badclasses) {
- if ($context eq 'auto') {
- $outcome .= " - $item\n";
- } else {
- $outcome .= "<li>$item</li>\n";
- }
- }
+ }
+ foreach my $item (@badclasses) {
if ($context eq 'auto') {
- $outcome .= $linefeed;
+ $outcome .= " - $item\n";
} else {
- $outcome .= "</ul><br /><br /></div>\n";
+ $outcome .= "<li>$item</li>\n";
}
+ }
+ if ($context eq 'auto') {
+ $outcome .= $linefeed;
+ } else {
+ $outcome .= "</ul><br /><br /></div>\n";
}
}
if ($args->{'no_end_date'}) {
@@ -15737,13 +16428,14 @@ sub group_term {
}
sub course_types {
- my @types = ('official','unofficial','community','textbook','placement');
+ my @types = ('official','unofficial','community','textbook','placement','lti');
my %typename = (
official => 'Official course',
unofficial => 'Unofficial course',
community => 'Community',
textbook => 'Textbook course',
placement => 'Placement test',
+ lti => 'LTI provider',
);
return (\@types,\%typename);
}
@@ -15823,6 +16515,24 @@ sub compare_arrays {
return @difference;
}
+sub lon_status_items {
+ my %defaults = (
+ E => 100,
+ W => 4,
+ N => 1,
+ U => 5,
+ threshold => 200,
+ sysmail => 2500,
+ );
+ my %names = (
+ E => 'Errors',
+ W => 'Warnings',
+ N => 'Notices',
+ U => 'Unsent',
+ );
+ return (\%defaults,\%names);
+}
+
# -------------------------------------------------------- Initialize user login
sub init_user_environment {
my ($r, $username, $domain, $authhost, $form, $args) = @_;
@@ -15830,8 +16540,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;
@@ -15853,12 +16561,29 @@ 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$/) {
- unlink($lonids.'/'.$filename);
+ 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);
+ }
}
}
closedir(DIR);
@@ -15893,8 +16618,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'})) {
@@ -15946,39 +16670,75 @@ sub init_user_environment {
$env{'user.noloadbalance'} = $lonhost;
}
- my %is_adv = ( is_adv => $env{'user.adv'} );
- my %domdef;
- unless ($domain eq 'public') {
- %domdef = &Apache::lonnet::get_domain_defaults($domain);
+ if ($form->{'noloadbalance'}) {
+ my @hosts = &Apache::lonnet::current_machine_ids();
+ my $hosthere = $form->{'noloadbalance'};
+ if (grep(/^\Q$hosthere\E$/,@hosts)) {
+ $initial_env{"user.noloadbalance"} = $hosthere;
+ $env{'user.noloadbalance'} = $hosthere;
+ }
}
- foreach my $tool ('aboutme','blog','webdav','portfolio') {
- $userenv{'availabletools.'.$tool} =
- &Apache::lonnet::usertools_access($username,$domain,$tool,'reload',
- undef,\%userenv,\%domdef,\%is_adv);
- }
+ unless ($domain eq 'public') {
+ my %is_adv = ( is_adv => $env{'user.adv'} );
+ my %domdef = &Apache::lonnet::get_domain_defaults($domain);
- foreach my $crstype ('official','unofficial','community','textbook','placement') {
- $userenv{'canrequest.'.$crstype} =
- &Apache::lonnet::usertools_access($username,$domain,$crstype,
- 'reload','requestcourses',
- \%userenv,\%domdef,\%is_adv);
- }
+ foreach my $tool ('aboutme','blog','webdav','portfolio') {
+ $userenv{'availabletools.'.$tool} =
+ &Apache::lonnet::usertools_access($username,$domain,$tool,'reload',
+ undef,\%userenv,\%domdef,\%is_adv);
+ }
- $userenv{'canrequest.author'} =
- &Apache::lonnet::usertools_access($username,$domain,'requestauthor',
- 'reload','requestauthor',
- \%userenv,\%domdef,\%is_adv);
- my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'],
- $domain,$username);
- my $reqstatus = $reqauthor{'author_status'};
- if ($reqstatus eq 'approval' || $reqstatus eq 'approved') {
- if (ref($reqauthor{'author'}) eq 'HASH') {
- $userenv{'requestauthorqueued'} = $reqstatus.':'.
- $reqauthor{'author'}{'timestamp'};
+ foreach my $crstype ('official','unofficial','community','textbook','placement','lti') {
+ $userenv{'canrequest.'.$crstype} =
+ &Apache::lonnet::usertools_access($username,$domain,$crstype,
+ 'reload','requestcourses',
+ \%userenv,\%domdef,\%is_adv);
}
- }
+ $userenv{'canrequest.author'} =
+ &Apache::lonnet::usertools_access($username,$domain,'requestauthor',
+ 'reload','requestauthor',
+ \%userenv,\%domdef,\%is_adv);
+ my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'],
+ $domain,$username);
+ my $reqstatus = $reqauthor{'author_status'};
+ if ($reqstatus eq 'approval' || $reqstatus eq 'approved') {
+ if (ref($reqauthor{'author'}) eq 'HASH') {
+ $userenv{'requestauthorqueued'} = $reqstatus.':'.
+ $reqauthor{'author'}{'timestamp'};
+ }
+ }
+ my ($types,$typename) = &course_types();
+ if (ref($types) eq 'ARRAY') {
+ my @options = ('approval','validate','autolimit');
+ my $optregex = join('|',@options);
+ my (%willtrust,%trustchecked);
+ foreach my $type (@{$types}) {
+ my $dom_str = $env{'environment.reqcrsotherdom.'.$type};
+ if ($dom_str ne '') {
+ my $updatedstr = '';
+ my @possdomains = split(',',$dom_str);
+ foreach my $entry (@possdomains) {
+ my ($extdom,$extopt) = split(':',$entry);
+ unless ($trustchecked{$extdom}) {
+ $willtrust{$extdom} = &Apache::lonnet::will_trust('reqcrs',$domain,$extdom);
+ $trustchecked{$extdom} = 1;
+ }
+ if ($willtrust{$extdom}) {
+ $updatedstr .= $entry.',';
+ }
+ }
+ $updatedstr =~ s/,$//;
+ if ($updatedstr) {
+ $userenv{'reqcrsotherdom.'.$type} = $updatedstr;
+ } else {
+ delete($userenv{'reqcrsotherdom.'.$type});
+ }
+ }
+ }
+ }
+ }
$env{'user.environment'} = "$lonids/$cookie.id";
if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
@@ -16595,7 +17355,7 @@ sub search_courses {
if (ref($courses{$cid}) eq 'HASH') {
if (ref($courses{$cid}{roles}) eq 'ARRAY') {
if (!grep(/^\Q$courserole\E$/,@{$courses{$cid}{roles}})) {
- push (@{$courses{$cid}{roles}},$courserole);
+ push(@{$courses{$cid}{roles}},$courserole);
}
} else {
$courses{$cid}{roles} = [$courserole];
@@ -16791,8 +17551,12 @@ sub needs_coursereinit {
$interval = 600;
}
if (($now-$env{'request.course.timechecked'})>$interval) {
- my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);
&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);
if ($lastchange > $env{'request.course.tied'}) {
my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
if ($curr_reqd_hash{'internal.releaserequired'} ne '') {
@@ -16815,22 +17579,34 @@ sub needs_coursereinit {
}
sub update_content_constraints {
- my ($cdom,$cnum,$chome,$cid) = @_;
+ my ($cdom,$cnum,$chome,$cid,$keeporder) = @_;
my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});
- my %checkresponsetypes;
+ my (%checkresponsetypes,%checkcrsrestypes);
foreach my $key (keys(%Apache::lonnet::needsrelease)) {
my ($item,$name,$value) = split(/:/,$key);
if ($item eq 'resourcetag') {
if ($name eq 'responsetype') {
$checkresponsetypes{$value} = $Apache::lonnet::needsrelease{$key}
}
+ } elsif ($item eq 'course') {
+ if ($name eq 'courserestype') {
+ $checkcrsrestypes{$value} = $Apache::lonnet::needsrelease{$key};
+ }
}
}
my $navmap = Apache::lonnavmaps::navmap->new();
if (defined($navmap)) {
- my %allresponses;
- foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() },1,0)) {
+ my (%allresponses,%allcrsrestypes);
+ foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() || $_[0]->is_tool() },1,0)) {
+ if ($res->is_tool()) {
+ if ($allcrsrestypes{'exttool'}) {
+ $allcrsrestypes{'exttool'} ++;
+ } else {
+ $allcrsrestypes{'exttool'} = 1;
+ }
+ next;
+ }
my %responses = $res->responseTypes();
foreach my $key (keys(%responses)) {
next unless(exists($checkresponsetypes{$key}));
@@ -16843,8 +17619,38 @@ sub update_content_constraints {
($reqdmajor,$reqdminor) = ($major,$minor);
}
}
+ foreach my $key (keys(%allcrsrestypes)) {
+ my ($major,$minor) = split(/\./,$checkcrsrestypes{$key});
+ if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) {
+ ($reqdmajor,$reqdminor) = ($major,$minor);
+ }
+ }
undef($navmap);
}
+ my (@resources,@order,@resparms,@zombies);
+ if ($keeporder) {
+ use LONCAPA::map;
+ @resources = @LONCAPA::map::resources;
+ @order = @LONCAPA::map::order;
+ @resparms = @LONCAPA::map::resparms;
+ @zombies = @LONCAPA::map::zombies;
+ }
+ my $suppmap = 'supplemental.sequence';
+ my ($suppcount,$supptools,$errors) = (0,0,0);
+ ($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap,
+ $suppcount,$supptools,$errors);
+ if ($keeporder) {
+ @LONCAPA::map::resources = @resources;
+ @LONCAPA::map::order = @order;
+ @LONCAPA::map::resparms = @resparms;
+ @LONCAPA::map::zombies = @zombies;
+ }
+ if ($supptools) {
+ my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'});
+ if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) {
+ ($reqdmajor,$reqdminor) = ($major,$minor);
+ }
+ }
unless (($reqdmajor eq '') && ($reqdminor eq '')) {
&Apache::lonnet::update_released_required($reqdmajor.'.'.$reqdminor,$cdom,$cnum,$chome,$cid);
}
@@ -16865,7 +17671,7 @@ sub allmaps_incourse {
if ($lastchange > $env{'request.course.tied'}) {
my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum");
unless ($ferr) {
- &update_content_constraints($cdom,$cnum,$chome,$cid);
+ &update_content_constraints($cdom,$cnum,$chome,$cid,1);
}
}
my $navmap = Apache::lonnavmaps::navmap->new();
@@ -16901,7 +17707,7 @@ sub parse_supplemental_title {
}
sub recurse_supplemental {
- my ($cnum,$cdom,$suppmap,$numfiles,$errors) = @_;
+ my ($cnum,$cdom,$suppmap,$numfiles,$numexttools,$errors) = @_;
if ($suppmap) {
my ($errtext,$fatal) = &LONCAPA::map::mapread('/uploaded/'.$cdom.'/'.$cnum.'/'.$suppmap);
if ($fatal) {
@@ -16912,8 +17718,12 @@ sub recurse_supplemental {
my ($title,$src,$ext,$type,$status)=split(/\:/,$res);
if (($src ne '') && ($status eq 'res')) {
if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) {
- ($numfiles,$errors) = &recurse_supplemental($cnum,$cdom,$1,$numfiles,$errors);
+ ($numfiles,$numexttools,$errors) = &recurse_supplemental($cnum,$cdom,$1,
+ $numfiles,$numexttools,$errors);
} else {
+ if ($src =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
+ $numexttools ++;
+ }
$numfiles ++;
}
}
@@ -16921,12 +17731,12 @@ sub recurse_supplemental {
}
}
}
- return ($numfiles,$errors);
+ return ($numfiles,$numexttools,$errors);
}
sub symb_to_docspath {
- my ($symb) = @_;
- return unless ($symb);
+ my ($symb,$navmapref) = @_;
+ return unless ($symb && ref($navmapref));
my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb);
if ($resurl=~/\.(sequence|page)$/) {
$mapurl=$resurl;
@@ -16934,9 +17744,11 @@ sub symb_to_docspath {
$mapurl=$env{'course.'.$env{'request.course.id'}.'.url'};
}
my $mapresobj;
- my $navmap = Apache::lonnavmaps::navmap->new();
- if (ref($navmap)) {
- $mapresobj = $navmap->getResourceByUrl($mapurl);
+ unless (ref($$navmapref)) {
+ $$navmapref = Apache::lonnavmaps::navmap->new();
+ }
+ if (ref($$navmapref)) {
+ $mapresobj = $$navmapref->getResourceByUrl($mapurl);
}
$mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1};
my $type=$2;
@@ -16946,7 +17758,7 @@ sub symb_to_docspath {
if ($pcslist ne '') {
foreach my $pc (split(/,/,$pcslist)) {
next if ($pc <= 1);
- my $res = $navmap->getByMapPc($pc);
+ my $res = $$navmapref->getByMapPc($pc);
if (ref($res)) {
my $thisurl = $res->src();
$thisurl=~s{^.*/([^/]+)\.\w+$}{$1};
@@ -16993,10 +17805,10 @@ sub symb_to_docspath {
}
sub captcha_display {
- my ($context,$lonhost) = @_;
+ my ($context,$lonhost,$defdom) = @_;
my ($output,$error);
my ($captcha,$pubkey,$privkey,$version) =
- &get_captcha_config($context,$lonhost);
+ &get_captcha_config($context,$lonhost,$defdom);
if ($captcha eq 'original') {
$output = &create_captcha();
unless ($output) {
@@ -17012,9 +17824,9 @@ sub captcha_display {
}
sub captcha_response {
- my ($context,$lonhost) = @_;
+ my ($context,$lonhost,$defdom) = @_;
my ($captcha_chk,$captcha_error);
- my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost);
+ my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom);
if ($captcha eq 'original') {
($captcha_chk,$captcha_error) = &check_captcha();
} elsif ($captcha eq 'recaptcha') {
@@ -17026,7 +17838,7 @@ sub captcha_response {
}
sub get_captcha_config {
- my ($context,$lonhost) = @_;
+ my ($context,$lonhost,$dom_in_effect) = @_;
my ($captcha,$pubkey,$privkey,$version,$hashtocheck);
my $hostname = &Apache::lonnet::hostname($lonhost);
my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);
@@ -17074,7 +17886,28 @@ 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);
}
@@ -17098,6 +17931,9 @@ sub create_captcha {
last;
}
}
+ if ($output eq '') {
+ &Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts.");
+ }
return $output;
}
@@ -17155,14 +17991,19 @@ sub check_recaptcha {
my ($privkey,$version) = @_;
my $captcha_chk;
if ($version >= 2) {
- my $ua = LWP::UserAgent->new;
- $ua->timeout(10);
my %info = (
secret => $privkey,
response => $env{'form.g-recaptcha-response'},
remoteip => $ENV{'REMOTE_ADDR'},
);
- my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);
+ my $request=new HTTP::Request('POST','https://www.google.com/recaptcha/api/siteverify');
+ $request->content(join('&',map {
+ my $name = escape($_);
+ "$name=" . ( ref($info{$_}) eq 'ARRAY'
+ ? join("&$name=", map {escape($_) } @{$info{$_}})
+ : &escape($info{$_}) );
+ } keys(%info)));
+ my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10,1);
if ($response->is_success) {
my $data = JSON::DWIW->from_json($response->decoded_content);
if (ref($data) eq 'HASH') {
@@ -17225,9 +18066,25 @@ 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) = @_;
+ my ($interval,$context) = @_;
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'},
$env{'user.name'});
&Apache::lonnet::appenv({'user.criticalcheck.time'=>time});
@@ -17293,6 +18150,293 @@ sub des_decrypt {
return $plaintext;
}
+sub make_short_symbs {
+ 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);
+ my %tocreate;
+ if (keys(%resources)) {
+ foreach my $item (sort {$a <=> $b} (@toshorten)) {
+ my $symb = $resources{$item};
+ if ($symb) {
+ $tocreate{$cnum.'&'.$symb} = 1;
+ }
+ }
+ }
+ 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;
+ my $lockhash = {
+ "lock\0$now" => $env{'user.name'}.
+ ':'.$env{'user.domain'},
+ };
+ 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'));
+ }
+ }
+ my $dellockres = &Apache::lonnet::del_dom('tiny',["lock\0$now"],$cdom);
+ unless ($dellockres eq 'ok') {
+ push(@errors,&mt('error: could not release lockfile'));
+ }
+ } else {
+ push(@errors,&mt('error: could not obtain lockfile'));
+ }
+ if (keys(%courseonly)) {
+ my $result = &Apache::lonnet::newput('tiny',\%courseonly,$cdom,$cnum);
+ if ($result ne 'ok') {
+ push(@errors,&mt('error: could not update course look-up of short 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;
+ }
+ }
+ }
+ 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 $response = &LONCAPA::LWPReq::makerequest('',$request,'','',5);
+ 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__;