--- loncom/interface/loncommon.pm 2021/06/20 18:30:11 1.1075.2.141.2.16
+++ loncom/interface/loncommon.pm 2020/02/04 21:54:58 1.1075.2.142
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1075.2.141.2.16 2021/06/20 18:30:11 raeburn Exp $
+# $Id: loncommon.pm,v 1.1075.2.142 2020/02/04 21:54:58 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -83,8 +83,6 @@ use Crypt::DES;
use DynaLoader; # for Crypt::DES version
use File::Copy();
use File::Path();
-use String::CRC32();
-use Short::URL();
# ---------------------------------------------- Designs
use vars qw(%defaultdesign);
@@ -430,7 +428,7 @@ sub studentbrowser_javascript {
OFFLOAD
+ }
}
}
}
@@ -8566,7 +8390,8 @@ sub modal_link {
$target_attr = 'target="'.$target.'"';
}
return <<"ENDLINK";
-$linktext
+
+ $linktext
ENDLINK
}
@@ -10459,15 +10284,11 @@ sub sorted_inst_types {
}
sub get_institutional_codes {
- my ($cdom,$crs,$settings,$allcourses,$LC_code) = @_;
+ my ($settings,$allcourses,$LC_code) = @_;
# Get complete list of course sections to update
my @currsections = ();
my @currxlists = ();
- my (%unclutteredsec,%unclutteredlcsec);
my $coursecode = $$settings{'internal.coursecode'};
- my $crskey = $crs.':'.$coursecode;
- @{$unclutteredsec{$crskey}} = ();
- @{$unclutteredlcsec{$crskey}} = ();
if ($$settings{'internal.sectionnums'} ne '') {
@currsections = split(/,/,$$settings{'internal.sectionnums'});
@@ -10478,8 +10299,8 @@ sub get_institutional_codes {
}
if (@currxlists > 0) {
- foreach my $xl (@currxlists) {
- if ($xl =~ /^([^:]+):(\w*)$/) {
+ foreach (@currxlists) {
+ if (m/^([^:]+):(\w*)$/) {
unless (grep/^$1$/,@{$allcourses}) {
push(@{$allcourses},$1);
$$LC_code{$1} = $2;
@@ -10487,28 +10308,15 @@ sub get_institutional_codes {
}
}
}
-
+
if (@currsections > 0) {
- foreach my $sec (@currsections) {
- if ($sec =~ m/^(\w+):(\w*)$/) {
- my $instsec = $1;
+ foreach (@currsections) {
+ if (m/^(\w+):(\w*)$/) {
+ my $sec = $coursecode.$1;
my $lc_sec = $2;
- unless (grep/^\Q$instsec\E$/,@{$unclutteredsec{$crskey}}) {
- push(@{$unclutteredsec{$crskey}},$instsec);
- push(@{$unclutteredlcsec{$crskey}},$lc_sec);
- }
- }
- }
- }
-
- if (@{$unclutteredsec{$crskey}} > 0) {
- my %formattedsec = &Apache::lonnet::auto_instsec_reformat($cdom,'clutter',\%unclutteredsec);
- if ((ref($formattedsec{$crskey}) eq 'ARRAY') && (ref($unclutteredlcsec{$crskey}) eq 'ARRAY')) {
- for (my $i=0; $i<@{$formattedsec{$crskey}}; $i++) {
- my $sec = $coursecode.$formattedsec{$crskey}[$i];
- unless (grep/^\Q$sec\E$/,@{$allcourses}) {
+ unless (grep/^$sec$/,@{$allcourses}) {
push(@{$allcourses},$sec);
- $$LC_code{$sec} = $unclutteredlcsec{$crskey}[$i];
+ $$LC_code{$sec} = $lc_sec;
}
}
}
@@ -15190,8 +14998,7 @@ sub check_clone {
my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
- my $clonetitle;
- my @clonemsg;
+ my $clonemsg;
my $can_clone = 0;
my $lctype = lc($args->{'crstype'});
if ($lctype ne 'community') {
@@ -15199,38 +15006,16 @@ sub check_clone {
}
if ($clonehome eq 'no_host') {
if ($args->{'crstype'} eq 'Community') {
- push(@clonemsg,({
- mt => 'No new community created.',
- args => [],
- },
- {
- mt => 'A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',
- args => [$args->{'clonedomain'}.':'.$args->{'clonedomain'}],
- }));
+ $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
} else {
- push(@clonemsg,({
- mt => 'No new course created.',
- args => [],
- },
- {
- mt => 'A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',
- args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}],
- }));
- }
+ $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
+ }
} else {
my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
- $clonetitle = $clonedesc{'description'};
if ($args->{'crstype'} eq 'Community') {
if ($clonedesc{'type'} ne 'Community') {
- push(@clonemsg,({
- mt => 'No new community created.',
- args => [],
- },
- {
- mt => 'A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',
- args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}],
- }));
- return ($can_clone,\@clonemsg,$cloneid,$clonehome);
+ $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
+ return ($can_clone, $clonemsg, $cloneid, $clonehome);
}
}
if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&
@@ -15319,34 +15104,20 @@ sub check_clone {
}
unless ($can_clone) {
if ($args->{'crstype'} eq 'Community') {
- push(@clonemsg,({
- mt => 'No new community created.',
- args => [],
- },
- {
- mt => 'The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',
- args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}],
- }));
+ $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
} else {
- push(@clonemsg,({
- mt => 'No new course created.',
- args => [],
- },
- {
- mt => 'The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',
- args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}],
- }));
- }
+ $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
+ }
}
}
}
- return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle);
+ return ($can_clone, $clonemsg, $cloneid, $clonehome);
}
sub construct_course {
my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
- $cnum,$category,$coderef,$callercontext,$user_lh) = @_;
- my ($outcome,$msgref,$clonemsgref);
+ $cnum,$category,$coderef) = @_;
+ my $outcome;
my $linefeed = '
'."\n";
if ($context eq 'auto') {
$linefeed = "\n";
@@ -15355,11 +15126,18 @@ sub construct_course {
#
# Are we cloning?
#
- my ($can_clone,$cloneid,$clonehome,$clonetitle);
+ my ($can_clone, $clonemsg, $cloneid, $clonehome);
if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
- ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed);
+ ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
+ if ($context ne 'auto') {
+ if ($clonemsg ne '') {
+ $clonemsg = ''.$clonemsg.'';
+ }
+ }
+ $outcome .= $clonemsg.$linefeed;
+
if (!$can_clone) {
- return (0,$outcome,$clonemsgref);
+ return (0,$outcome);
}
}
@@ -15377,20 +15155,15 @@ sub construct_course {
$args->{'ccuname'}.':'.
$args->{'ccdomain'},
$args->{'crstype'},
- $cnum,$context,$category,
- $callercontext);
+ $cnum,$context,$category);
# Note: The testing routines depend on this being output; see
# Utils::Course. This needs to at least be output as a comment
# if anyone ever decides to not show this, and Utils::Course::new
# will need to be suitably modified.
- if (($callercontext eq 'auto') && ($user_lh ne '')) {
- $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
- } else {
- $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
- }
+ $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
if ($$courseid =~ /^error:/) {
- return (0,$outcome,$clonemsgref);
+ return (0,$outcome);
}
#
@@ -15399,37 +15172,23 @@ sub construct_course {
($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
if ($crsuhome eq 'no_host') {
- if (($callercontext eq 'auto') && ($user_lh ne '')) {
- $outcome .= &mt_user($user_lh,
- 'Course creation failed, unrecognized course home server.');
- } else {
- $outcome .= &mt('Course creation failed, unrecognized course home server.');
- }
- $outcome .= $linefeed;
- return (0,$outcome,$clonemsgref);
+ $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed;
+ return (0,$outcome);
}
$outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
#
# Do the cloning
#
- my @clonemsg;
if ($can_clone && $cloneid) {
- push(@clonemsg,
- {
- mt => 'Created [_1] by cloning from [_2]',
- args => [$crstype,$clonetitle],
- });
+ $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
+ if ($context ne 'auto') {
+ $clonemsg = ''.$clonemsg.'';
+ }
+ $outcome .= $clonemsg.$linefeed;
my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
# Copy all files
- my @info =
- &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},
- $args->{'dateshift'},$args->{'crscode'},
- $args->{'ccuname'}.':'.$args->{'ccdomain'},
- $args->{'tinyurls'});
- if (@info) {
- push(@clonemsg,@info);
- }
+ &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
# Restore URL
$cenv{'url'}=$oldcenv{'url'};
# Restore title
@@ -15696,17 +15455,12 @@ sub construct_course {
# Open all assignments
#
if ($args->{'openall'}) {
- my $opendate = time;
- if ($args->{'openallfrom'} =~ /^\d+$/) {
- $opendate = $args->{'openallfrom'};
- }
my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
- my %storecontent = ($storeunder => $opendate,
+ my %storecontent = ($storeunder => time,
$storeunder.'.type' => 'date_start');
- $outcome .= &mt('All assignments open starting [_1]',
- &Apache::lonlocal::locallocaltime($opendate)).': '.
- &Apache::lonnet::cput
- ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
+
+ $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
+ ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
}
#
# Set first page
@@ -15736,7 +15490,7 @@ sub construct_course {
$outcome .= ($fatal?$errtext:'write ok').$linefeed;
}
- return (1,$outcome,\@clonemsg);
+ return (1,$outcome);
}
sub make_unique_code {
@@ -15905,24 +15659,6 @@ 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) = @_;
@@ -16025,7 +15761,6 @@ sub init_user_environment {
# --------------------------------------------------------- Write first profile
{
- my $ip = &Apache::lonnet::get_requestor_ip();
my %initial_env =
("user.name" => $username,
"user.domain" => $domain,
@@ -16044,7 +15779,7 @@ sub init_user_environment {
"request.course.sec" => '',
"request.role" => 'cm',
"request.role.adv" => $env{'user.adv'},
- "request.host" => $ip,);
+ "request.host" => $ENV{'REMOTE_ADDR'},);
if ($form->{'localpath'}) {
$initial_env{"browser.localpath"} = $form->{'localpath'};
@@ -16904,12 +16639,8 @@ sub needs_coursereinit {
$interval = 600;
}
if (($now-$env{'request.course.timechecked'})>$interval) {
- &Apache::lonnet::appenv({'request.course.timechecked'=>$now});
- my $blocked = &blocking_status('reinit',$cnum,$cdom,undef,1);
- if ($blocked) {
- return ();
- }
my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);
+ &Apache::lonnet::appenv({'request.course.timechecked'=>$now});
if ($lastchange > $env{'request.course.tied'}) {
my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
if ($curr_reqd_hash{'internal.releaserequired'} ne '') {
@@ -17294,14 +17025,13 @@ sub create_recaptcha {
sub check_recaptcha {
my ($privkey,$version) = @_;
my $captcha_chk;
- my $ip = &Apache::lonnet::get_requestor_ip();
if ($version >= 2) {
my $ua = LWP::UserAgent->new;
$ua->timeout(10);
my %info = (
secret => $privkey,
response => $env{'form.g-recaptcha-response'},
- remoteip => $ip,
+ remoteip => $ENV{'REMOTE_ADDR'},
);
my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info);
if ($response->is_success) {
@@ -17317,7 +17047,7 @@ sub check_recaptcha {
my $captcha_result =
$captcha->check_answer(
$privkey,
- $ip,
+ $ENV{'REMOTE_ADDR'},
$env{'form.recaptcha_challenge_field'},
$env{'form.recaptcha_response_field'},
);
@@ -17366,25 +17096,9 @@ sub cleanup_html {
# Checks for critical messages and returns a redirect url if one exists.
# $interval indicates how often to check for messages.
-# $context is the calling context -- roles, grades, contents, menu or flip.
sub critical_redirect {
- my ($interval,$context) = @_;
+ my ($interval) = @_;
if ((time-$env{'user.criticalcheck.time'})>$interval) {
- if (($env{'request.course.id'}) && (($context eq 'flip') || ($context eq 'contents'))) {
- my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
- my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
- my $blocked = &blocking_status('alert',$cnum,$cdom,undef,1);
- if ($blocked) {
- my $checkrole = "cm./$cdom/$cnum";
- if ($env{'request.course.sec'} ne '') {
- $checkrole .= "/$env{'request.course.sec'}";
- }
- unless ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) &&
- ($env{'request.role'} !~ m{^st\./$cdom/$cnum})) {
- return;
- }
- }
- }
my @what=&Apache::lonnet::dump('critical', $env{'user.domain'},
$env{'user.name'});
&Apache::lonnet::appenv({'user.criticalcheck.time'=>time});
@@ -17450,146 +17164,6 @@ sub des_decrypt {
return $plaintext;
}
-sub get_requested_shorturls {
- my ($cdom,$cnum,$navmap) = @_;
- return unless (ref($navmap));
- my ($numnew,$errors);
- my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny');
- if (@toshorten) {
- my (%maps,%resources,%titles);
- &Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles,
- 'shorturls',$cdom,$cnum);
- if (keys(%resources)) {
- my %tocreate;
- foreach my $item (sort {$a <=> $b} (@toshorten)) {
- my $symb = $resources{$item};
- if ($symb) {
- $tocreate{$cnum.'&'.$symb} = 1;
- }
- }
- if (keys(%tocreate)) {
- ($numnew,$errors) = &make_short_symbs($cdom,$cnum,
- \%tocreate);
- }
- }
- }
- return ($numnew,$errors);
-}
-
-sub make_short_symbs {
- my ($cdom,$cnum,$tocreateref,$lockuser) = @_;
- my ($numnew,@errors);
- if (ref($tocreateref) eq 'HASH') {
- my %tocreate = %{$tocreateref};
- if (keys(%tocreate)) {
- my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum);
- my $su = Short::URL->new(no_vowels => 1);
- my $init = '';
- my (%newunique,%addcourse,%courseonly,%failed);
- # get lock on tiny db
- my $now = time;
- if ($lockuser eq '') {
- $lockuser = $env{'user.name'}.':'.$env{'user.domain'};
- }
- my $lockhash = {
- "lock\0$now" => $lockuser,
- };
- my $tries = 0;
- my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
- my ($code,$error);
- while (($gotlock ne 'ok') && ($tries<3)) {
- $tries ++;
- sleep 1;
- $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
- }
- if ($gotlock eq 'ok') {
- $init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique,
- \%addcourse,\%courseonly,\%failed);
- if (keys(%failed)) {
- my $numfailed = scalar(keys(%failed));
- push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed));
- }
- if (keys(%newunique)) {
- my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom);
- if ($putres eq 'ok') {
- $numnew = scalar(keys(%newunique));
- my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum);
- unless ($newputres eq 'ok') {
- push(@errors,&mt('error: could not store course look-up of short URLs'));
- }
- } else {
- push(@errors,&mt('error: could not store unique six character URLs'));
- }
- }
- }
- }
- }
- return ($numnew,\@errors);
-}
-
-sub shorten_symbs {
- my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_;
- return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') &&
- (ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') &&
- (ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH'));
- my (%possibles,%collisions);
- foreach my $key (keys(%{$tocreate})) {
- my $num = String::CRC32::crc32($key);
- my $tiny = $su->encode($num,$init);
- if ($tiny) {
- $possibles{$tiny} = $key;
- }
- }
- if (!$init) {
- $init = 1;
- } else {
- $init ++;
- }
- if (keys(%possibles)) {
- my @posstiny = keys(%possibles);
- my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
- my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname);
- if (keys(%currtiny)) {
- foreach my $key (keys(%currtiny)) {
- next if ($currtiny{$key} eq '');
- if ($currtiny{$key} eq $possibles{$key}) {
- my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key});
- unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) {
- $courseonly->{$tsymb} = $key;
- }
- } else {
- $collisions{$possibles{$key}} = 1;
- }
- delete($possibles{$key});
- }
- }
- foreach my $key (keys(%possibles)) {
- $newunique->{$key} = $possibles{$key};
- my ($tcnum,$tsymb) = split(/\&/,$possibles{$key});
- unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) {
- $addcourse->{$tsymb} = $key;
- }
- }
- }
- if (keys(%collisions)) {
- if ($init <5) {
- if (!$init) {
- $init = 1;
- } else {
- $init ++;
- }
- $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions,
- $newunique,$addcourse,$courseonly,$failed);
- } else {
- foreach my $key (keys(%collisions)) {
- $failed->{$key} = 1;
- $failed->{$key} = 1;
- }
- }
- }
- return $init;
-}
-
sub is_nonframeable {
my ($url,$absolute,$hostname,$ip,$nocache) = @_;
my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i);