--- loncom/interface/loncommon.pm 2016/11/26 19:40:44 1.1266
+++ loncom/interface/loncommon.pm 2018/07/04 13:44:16 1.1319
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1266 2016/11/26 19:40:44 raeburn Exp $
+# $Id: loncommon.pm,v 1.1319 2018/07/04 13:44:16 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -71,6 +71,7 @@ use Apache::lonuserutils();
use Apache::lonuserstate();
use Apache::courseclassifier();
use LONCAPA qw(:DEFAULT :match);
+use LONCAPA::LWPReq;
use DateTime::TimeZone;
use DateTime::Locale;
use Encode();
@@ -83,6 +84,10 @@ 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,7 +267,7 @@ BEGIN {
{
my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
'/filecategories.tab';
- if ( open (my $fh,"<$categoryfile") ) {
+ if ( open (my $fh,'<',$categoryfile) ) {
while (my $line = <$fh>) {
next if ($line =~ /^\#/);
chomp($line);
@@ -277,7 +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);
@@ -1292,9 +1297,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.=''
- .''
+ .' '
.$text.' ';
}
@@ -1304,7 +1313,7 @@ sub help_open_topic {
if ($imgid ne '') {
$imgid = ' id="'.$imgid.'"';
}
- $template.=' '
+ $template.=' '
.' $text ";
+ "
$text ";
}
# Add the graphic
my $title = &mt('Report a Bug');
my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
$template .= <<"ENDTEMPLATE";
-
+
ENDTEMPLATE
if ($text ne '') { $template.=' ' };
return $template;
@@ -2220,6 +2234,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 +2278,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 +2493,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))];
@@ -3008,6 +3039,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.
@@ -3424,14 +3457,69 @@ sub authform_filesystem {
$fsyscheck.' onchange="'.$jscall.'" onclick="'.
$jscall.'"'.$disabled.' />';
}
- $autharg = ' ';
$result = &mt
('[_1] Filesystem Authenticated (with initial password [_2])',
- ' ',
- ' ');
+ ''.$authtype,' '.$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 = ' ';
+ }
+ }
+ if (!$can_assign{'lti'}) {
+ return;
+ } elsif ($authtype eq '') {
+ if (defined($in{'mode'})) {
+ if ($in{'mode'} eq 'modifycourse') {
+ if ($authnum == 1) {
+ $authtype = ' ';
+ }
+ }
+ }
+ }
+ $jscall = "javascript:changed_radio('lti',$in{'formname'});";
+ if (($authtype eq '') && (($in{'mode'} eq 'modifycourse') || ($in{'curr_authtype'} ne 'lti'))) {
+ $authtype = ' ';
+ }
+ $autharg = ' ';
+ if ($authtype) {
+ $result = &mt('[_1] LTI Authenticated',
+ ''.$authtype.' '.$autharg);
+ } else {
+ $result = ''.&mt('LTI Authenticated').' '.
+ $autharg;
+ }
return $result;
}
@@ -3445,6 +3533,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') {
@@ -4562,9 +4651,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().
- ''.&mt('Nothing submitted - no attempts.').' '.
+ ''.$msg.' '.
&end_data_table_row().&end_data_table();
}
} else {
@@ -4669,6 +4764,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/\]*\>//gi;
$userview=~s/\<\/body\>//gi;
@@ -4991,7 +5089,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'}) {
@@ -5075,7 +5174,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;
@@ -5097,9 +5196,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) &&
@@ -5186,13 +5285,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,
+ };
+ }
+ }
+ }
}
}
}
@@ -5302,6 +5407,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";
@@ -5541,7 +5650,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);
@@ -5740,13 +5849,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 =
'
'
.&Apache::loncommon::help_open_menu('','',3,'Authoring') #FIXME: Broken? Where is it?
.'
'.$title.' '
- .'
'
.&Apache::lonmenu::constspaceform();
@@ -5809,11 +5923,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://
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.
@@ -5825,7 +5956,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'))
@@ -5834,6 +5965,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);
@@ -5862,7 +5994,11 @@ sub bodytag {
if ($env{'request.role'} !~ /^cr/) {
$role = &Apache::lonnet::plaintext($role,&course_type());
} elsif ($role =~ m{^cr/($match_domain)/\1-domainconfig/(\w+)$}) {
- $role = &mt('Helpdesk[_1]',' '.$2);
+ if ($env{'request.role.desc'}) {
+ $role = $env{'request.role.desc'};
+ } else {
+ $role = &mt('Helpdesk[_1]',' '.$2);
+ }
} else {
$role = (split(/\//,$role,4))[-1];
}
@@ -5891,7 +6027,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 = ''.$title.' ';
#
# Extra info if you are the DC
@@ -5925,27 +6072,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|$dc_info |;
- }
- $bodytag .= qq|$left $role
- $realm $dc_info
|;
- return $bodytag;
- }
+ if ($env{'request.noversionuri'} =~ m{^/res/adm/pages/}) {
+ if ($dc_info) {
+ $dc_info = qq|$dc_info |;
+ }
+ $bodytag .= qq|$left $role
+ $realm $dc_info
|;
+ return $bodytag;
+ }
- unless ($env{'request.symb'} =~ m/\.page___\d+___/) {
- $bodytag .= qq|$left $role
|;
- }
+ unless ($env{'request.symb'} =~ m/\.page___\d+___/) {
+ $bodytag .= qq|$left $role
|;
+ }
- $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|$realm $dc_info
|;
}
- $bodytag .= qq|$realm $dc_info
|;
#if directed to not display the secondary menu, don't.
if ($args->{'no_secondary_menu'}) {
@@ -5953,22 +6102,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->{'hide_buttons'});
+ $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
@@ -6430,6 +6583,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;
@@ -6751,6 +6909,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;
@@ -7102,6 +7266,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;
@@ -8122,6 +8292,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
}
@@ -8314,6 +8517,7 @@ OFFLOAD
';
}
+ $result .= ' '."\n";
return $result.'';
}
@@ -8493,8 +8697,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:// if server uses
+ https (as per hosts.tab), but request is for http
+ hostname -> hostname, originally from $r->hostname(), (optional).
=back
@@ -8507,11 +8717,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'}) {
@@ -8525,7 +8766,7 @@ sub start_page {
$args->{'only_body'}, $args->{'domain'},
$args->{'force_register'}, $args->{'no_nav_bar'},
$args->{'bgcolor'}, $args,
- \@advtools);
+ \@advtools,$ltiscope,$ltiuri,\%ltimenu);
}
}
@@ -8558,15 +8799,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;
@@ -8792,8 +9040,9 @@ sub end_togglebox {
}
sub LCprogressbar_script {
- my ($id)=@_;
- return(<
//
ENDPROGRESS
+ } else {
+ return(<
+//
+
+ENDPROGRESS
+ }
}
sub LCprogressbarUpdate_script {
return(<
.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; }
@@ -8832,37 +9103,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=(<
$starting
ENDPROGBAR
- &r_print($r,$content.&LCprogressbar_script($LCcurrentid));
+ } else {
+ $starting=&mt('Loading...');
+ $LClastpercent='false';
+ $content=(<
+ $starting
+
+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
@@ -9047,14 +9335,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).
''.$msg.'
'.
&Apache::loncommon::end_page();
if (ref($r)) {
@@ -9982,7 +10277,7 @@ sub get_secgrprole_info {
}
sub user_picker {
- my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom) = @_;
+ my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom,$noinstd) = @_;
my $currdom = $dom;
my @alldoms = &Apache::lonnet::all_domains();
if (@alldoms == 1) {
@@ -10047,10 +10342,21 @@ sub user_picker {
&html_escape(\%html_lt);
&js_escape(\%js_lt);
my $domform;
+ my $allow_blank = 1;
if ($fixeddom) {
- $domform = &select_dom_form($currdom,'srchdomain',1,1,undef,[$currdom]);
+ $allow_blank = 0;
+ $domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,[$currdom]);
} else {
- $domform = &select_dom_form($currdom,'srchdomain',1,1);
+ 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 = ' ';
@@ -10063,6 +10369,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 .= '
'.$html_lt{$option}.' ';
@@ -11901,7 +12208,7 @@ sub modify_html_refs {
return;
}
}
- if (open(my $fh,"<$container")) {
+ if (open(my $fh,'<',$container)) {
$content = join('', <$fh>);
close($fh);
} else {
@@ -11966,7 +12273,7 @@ sub modify_html_refs {
}
}
} else {
- if (open(my $fh,">$container")) {
+ if (open(my $fh,'>',$container)) {
print $fh $content;
close($fh);
$output = ''.&mt('Updated [quant,_1,reference] in [_2].',
@@ -12483,6 +12790,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 '
'.&mt('Not extracted.').' '.
+ &mt('Unexpected file path.').'
'."\n";
+ }
+ unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) {
+ return ''.&mt('Not extracted.').' '.
+ &mt('Unexpected course context.').'
'."\n";
+ }
+ unless ($file eq &Apache::lonnet::clean_filename($file)) {
+ return ''.&mt('Not extracted.').' '.
+ &mt('Filename contained unexpected characters.').'
'."\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.').
@@ -12517,30 +12836,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);
@@ -12558,8 +12891,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;
@@ -13044,7 +13376,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);
@@ -13057,7 +13389,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+)/});
@@ -13146,7 +13478,9 @@ sub process_extracted_files {
'.'.$containers{$outer},1,1);
$newseqid{$i} = $newidx;
unless ($errtext) {
- $result .= ''.&mt('Folder: [_1] added to course',$docstitle).' '."\n";
+ $result .= ''.&mt('Folder: [_1] added to course',
+ &HTML::Entities::encode($docstitle,'<>&"')).
+ ' '."\n";
}
}
} else {
@@ -13155,38 +13489,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 .= ''.&mt('File: [_1] added to course',$docstitle).' '."\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 .= ''.&mt('File: [_1] added to course',
+ &HTML::Entities::encode($docstitle,'<>&"')).
+ ' '."\n";
+ }
+ }
+ } else {
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path,'<>&"')).' ';
}
}
}
}
} else {
- $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).' ';
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path,'<>&"')).' ';
}
}
for (my $i=1; $i<=$numitems; $i++) {
@@ -13247,7 +13590,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').' ';
+ }
}
if (-e "$fullpath/$title") {
my $showpath;
@@ -13256,21 +13601,26 @@ sub process_extracted_files {
} else {
$showpath = "/$title";
}
- $result .= ''.&mt('[_1] included as a dependency',$showpath).' '."\n";
- }
- unless ($ishome) {
- my $fetch = "$fullpath/$title";
- $fetch =~ s/^\Q$prefix$dir\E//;
- $prompttofetch{$fetch} = 1;
+ $result .= ''.&mt('[_1] included as a dependency',
+ &HTML::Entities::encode($showpath,'<>&"')).
+ ' '."\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}}).' ';
+ &HTML::Entities::encode($path,'<>&"'),
+ &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')).
+ ' ';
}
} else {
- $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).' ';
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path)).' ';
}
}
if (keys(%todelete)) {
@@ -13544,12 +13894,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);
}
@@ -13559,21 +13912,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);
}
@@ -13581,6 +13935,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()
@@ -14467,7 +14829,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.
@@ -14478,11 +14847,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') {
@@ -14494,14 +14863,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 '') {
@@ -14521,8 +15059,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;
+ }
}
############################################################
@@ -15772,13 +16323,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);
}
@@ -15865,8 +16417,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;
@@ -15888,12 +16438,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 ($ENV{'SERVER_PORT'} == 443) {
+ my $linkedfile;
+ if (tie(my %oldenv,'GDBM_File',"$lonids/$cookie.id",
+ &GDBM_READER(),0640)) {
+ if (exists($oldenv{'user.linkedenv'})) {
+ $linkedfile = $oldenv{'user.linkedenv'};
+ }
+ untie(%oldenv);
+ }
+ if (unlink($lonids.'/'.$filename)) {
+ if ($linkedfile =~ /^[a-f0-9]+_linked\.id$/) {
+ unlink($lonids.'/'.$linkedfile);
+ }
+ }
+ } else {
+ unlink($lonids.'/'.$filename);
+ }
}
}
closedir(DIR);
@@ -15928,8 +16495,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'})) {
@@ -15981,39 +16547,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",
@@ -16826,8 +17428,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 '') {
@@ -16853,19 +17459,31 @@ sub update_content_constraints {
my ($cdom,$cnum,$chome,$cid) = @_;
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}));
@@ -16878,8 +17496,24 @@ 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 $suppmap = 'supplemental.sequence';
+ my ($suppcount,$supptools,$errors) = (0,0,0);
+ ($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap,
+ $suppcount,$supptools,$errors);
+ 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);
}
@@ -16936,7 +17570,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) {
@@ -16947,8 +17581,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 ++;
}
}
@@ -16956,12 +17594,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;
@@ -16969,9 +17607,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;
@@ -16981,7 +17621,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};
@@ -17190,14 +17830,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') {
@@ -17260,9 +17905,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});
@@ -17328,6 +17989,142 @@ 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;
+}
+
1;
__END__;