--- loncom/interface/loncommon.pm 2020/07/19 21:33:46 1.1075.2.141.2.5
+++ loncom/interface/loncommon.pm 2020/05/02 18:27:56 1.1075.2.145
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1075.2.141.2.5 2020/07/19 21:33:46 raeburn Exp $
+# $Id: loncommon.pm,v 1.1075.2.145 2020/05/02 18:27:56 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);
@@ -5037,7 +5035,8 @@ sub check_ip_acc {
if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
return 1;
}
- my ($ip,$allowed);
+ my $allowed=0;
+ my $ip;
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;
@@ -5046,34 +5045,13 @@ sub check_ip_acc {
}
my $name;
- my %access = (
- allowfrom => 1,
- denyfrom => 0,
- );
- my @allows;
- my @denies;
- foreach my $item (split(',',$acc)) {
- $item =~ s/^\s*//;
- $item =~ s/\s*$//;
- if ($item =~ /^\!(.+)$/) {
- push(@denies,$1);
- } else {
- push(@allows,$item);
- }
- }
- my $numdenies = scalar(@denies);
- my $numallows = scalar(@allows);
- my $count = 0;
- foreach my $pattern (@denies,@allows) {
- $count ++;
- my $acctype = 'allowfrom';
- if ($count <= $numdenies) {
- $acctype = 'denyfrom';
- }
+ foreach my $pattern (split(',',$acc)) {
+ $pattern =~ s/^\s*//;
+ $pattern =~ s/\s*$//;
if ($pattern =~ /\*$/) {
#35.8.*
$pattern=~s/\*//;
- if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }
+ if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
} elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
#35.8.3.[34-56]
my $low=$2;
@@ -5081,7 +5059,7 @@ sub check_ip_acc {
$pattern=$1;
if ($ip =~ /^\Q$pattern\E/) {
my $last=(split(/\./,$ip))[3];
- if ($last <=$high && $last >=$low) { $allowed=$access{$acctype}; }
+ if ($last <=$high && $last >=$low) { $allowed=1; }
}
} elsif ($pattern =~ /^\*/) {
#*.msu.edu
@@ -5091,10 +5069,10 @@ sub check_ip_acc {
my $netaddr=inet_aton($ip);
($name)=gethostbyaddr($netaddr,AF_INET);
}
- if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }
+ if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
} elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
#127.0.0.1
- if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; }
+ if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
} else {
#some.name.com
if (!defined($name)) {
@@ -5102,16 +5080,9 @@ sub check_ip_acc {
my $netaddr=inet_aton($ip);
($name)=gethostbyaddr($netaddr,AF_INET);
}
- if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; }
- }
- if ($allowed =~ /^(0|1)$/) { last; }
- }
- if ($allowed eq '') {
- if ($numdenies && !$numallows) {
- $allowed = 1;
- } else {
- $allowed = 0;
+ if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
}
+ if ($allowed) { last; }
}
return $allowed;
}
@@ -15082,8 +15053,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') {
@@ -15091,38 +15061,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'}) &&
@@ -15211,34 +15159,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";
@@ -15247,11 +15181,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);
}
}
@@ -15269,20 +15210,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);
}
#
@@ -15291,37 +15227,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
@@ -15588,17 +15510,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
@@ -15628,7 +15545,7 @@ sub construct_course {
$outcome .= ($fatal?$errtext:'write ok').$linefeed;
}
- return (1,$outcome,\@clonemsg);
+ return (1,$outcome);
}
sub make_unique_code {
@@ -17302,146 +17219,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);