--- loncom/interface/loncommon.pm 2019/05/02 02:12:18 1.1328
+++ loncom/interface/loncommon.pm 2020/09/28 00:10:28 1.1347
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1328 2019/05/02 02:12:18 raeburn Exp $
+# $Id: loncommon.pm,v 1.1347 2020/09/28 00:10:28 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -80,7 +80,6 @@ use Text::Aspell;
use Authen::Captcha;
use Captcha::reCAPTCHA;
use JSON::DWIW;
-use LWP::UserAgent;
use Crypt::DES;
use DynaLoader; # for Crypt::DES version
use MIME::Lite;
@@ -436,7 +435,7 @@ sub studentbrowser_javascript {
OFFLOAD
- }
}
}
}
@@ -8937,8 +9088,7 @@ sub modal_link {
$target_attr = 'target="'.$target.'"';
}
return <<"ENDLINK";
-
- $linktext
+$linktext
ENDLINK
}
@@ -15094,6 +15244,8 @@ Inputs:
from - Sender's email address
+replyto - Reply-To email address
+
to - Email address of recipient
subject - Subject of email
@@ -15104,8 +15256,6 @@ cc_string - Carbon copy email ad
bcc - Blind carbon copy email address
-type - File type of attachment
-
attachment_path - Path of file to be attached
file_name - Name of file to be attached
@@ -15122,8 +15272,9 @@ attachment_text - The body of an attac
############################################################
sub mime_email {
- my ($from, $to, $subject, $body, $cc_string, $bcc, $attachment_path,
- $file_name, $attachment_text) = @_;
+ my ($from,$replyto,$to,$subject,$body,$cc_string,$bcc,$attachment_path,
+ $file_name,$attachment_text) = @_;
+
my $msg = MIME::Lite->new(
From => $from,
To => $to,
@@ -15131,6 +15282,9 @@ sub mime_email {
Type =>'TEXT',
Data => $body,
);
+ if ($replyto ne '') {
+ $msg->add("Reply-To" => $replyto);
+ }
if ($cc_string ne '') {
$msg->add("Cc" => $cc_string);
}
@@ -15729,7 +15883,8 @@ sub check_clone {
my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
- my $clonemsg;
+ my $clonetitle;
+ my @clonemsg;
my $can_clone = 0;
my $lctype = lc($args->{'crstype'});
if ($lctype ne 'community') {
@@ -15737,16 +15892,38 @@ sub check_clone {
}
if ($clonehome eq 'no_host') {
if ($args->{'crstype'} eq 'Community') {
- $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
+ 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'}],
+ }));
} else {
- $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'});
- }
+ 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'}],
+ }));
+ }
} else {
my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
+ $clonetitle = $clonedesc{'description'};
if ($args->{'crstype'} eq 'Community') {
if ($clonedesc{'type'} ne 'Community') {
- $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
- return ($can_clone, $clonemsg, $cloneid, $clonehome);
+ 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);
}
}
if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&
@@ -15835,20 +16012,34 @@ sub check_clone {
}
unless ($can_clone) {
if ($args->{'crstype'} eq 'Community') {
- $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'});
+ 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'}],
+ }));
} else {
- $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'});
+ 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'}],
+ }));
}
}
}
}
- return ($can_clone, $clonemsg, $cloneid, $clonehome);
+ return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle);
}
sub construct_course {
my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
- $cnum,$category,$coderef) = @_;
- my $outcome;
+ $cnum,$category,$coderef,$callercontext,$user_lh) = @_;
+ my ($outcome,$msgref,$clonemsgref);
my $linefeed = '
'."\n";
if ($context eq 'auto') {
$linefeed = "\n";
@@ -15857,18 +16048,11 @@ sub construct_course {
#
# Are we cloning?
#
- my ($can_clone, $clonemsg, $cloneid, $clonehome);
+ my ($can_clone,$cloneid,$clonehome,$clonetitle);
if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
- ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
- if ($context ne 'auto') {
- if ($clonemsg ne '') {
- $clonemsg = ''.$clonemsg.'';
- }
- }
- $outcome .= $clonemsg.$linefeed;
-
+ ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed);
if (!$can_clone) {
- return (0,$outcome);
+ return (0,$outcome,$clonemsgref);
}
}
@@ -15891,15 +16075,20 @@ sub construct_course {
$args->{'ccuname'}.':'.
$args->{'ccdomain'},
$args->{'crstype'},
- $cnum,$context,$category);
+ $cnum,$context,$category,
+ $callercontext);
# 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.
- $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed;
+ if (($callercontext eq 'auto') && ($user_lh ne '')) {
+ $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed;
+ } else {
+ $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed;
+ }
if ($$courseid =~ /^error:/) {
- return (0,$outcome);
+ return (0,$outcome,$clonemsgref);
}
#
@@ -15908,23 +16097,37 @@ sub construct_course {
($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
if ($crsuhome eq 'no_host') {
- $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed;
- return (0,$outcome);
+ 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('Created on').': '.$crsuhome.$linefeed;
#
# Do the cloning
#
+ my @clonemsg;
if ($can_clone && $cloneid) {
- $clonemsg = &mt('Cloning [_1] from [_2]',$showncrstype,$clonehome);
- if ($context ne 'auto') {
- $clonemsg = ''.$clonemsg.'';
- }
- $outcome .= $clonemsg.$linefeed;
+ push(@clonemsg,
+ {
+ mt => 'Created [_1] by cloning from [_2]',
+ args => [$showncrstype,$clonetitle],
+ });
my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
# Copy all files
- &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
+ my @info =
+ &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},
+ $args->{'dateshift'},$args->{'crscode'},
+ $args->{'ccuname'}.':'.$args->{'ccdomain'},
+ $args->{'tinyurls'});
+ if (@info) {
+ push(@clonemsg,@info);
+ }
# Restore URL
$cenv{'url'}=$oldcenv{'url'};
# Restore title
@@ -16191,12 +16394,17 @@ 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 => time,
+ my %storecontent = ($storeunder => $opendate,
$storeunder.'.type' => 'date_start');
-
- $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
- ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
+ $outcome .= &mt('All assignments open starting [_1]',
+ &Apache::lonlocal::locallocaltime($opendate)).': '.
+ &Apache::lonnet::cput
+ ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
}
#
# Set first page
@@ -16250,7 +16458,7 @@ sub construct_course {
('resourcedata',\%storecontent,$$crsudom,$$crsunum);
}
- return (1,$outcome);
+ return (1,$outcome,\@clonemsg);
}
sub make_unique_code {
@@ -18056,24 +18264,37 @@ sub des_decrypt {
return $plaintext;
}
-sub make_short_symbs {
+sub get_requested_shorturls {
my ($cdom,$cnum,$navmap) = @_;
return unless (ref($navmap));
- my ($numnew,@errors);
+ 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)) {
+ 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);
@@ -18081,9 +18302,11 @@ sub make_short_symbs {
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" => $env{'user.name'}.
- ':'.$env{'user.domain'},
+ "lock\0$now" => $lockuser,
};
my $tries = 0;
my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
@@ -18193,7 +18416,26 @@ sub shorten_symbs {
}
sub is_nonframeable {
- my ($url,$absolute,$hostname,$ip) = @_;
+ my ($url,$absolute,$hostname,$ip,$nocache) = @_;
+ my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i);
+ return if (($remprotocol eq '') || ($remhost eq ''));
+
+ $remprotocol = lc($remprotocol);
+ $remhost = lc($remhost);
+ my $remport = 80;
+ if ($remprotocol eq 'https') {
+ $remport = 443;
+ }
+ my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport);
+ if ($cached) {
+ unless ($nocache) {
+ if ($result) {
+ return 1;
+ } else {
+ return 0;
+ }
+ }
+ }
my $uselink;
my $request = new HTTP::Request('HEAD',$url);
my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',5);
@@ -18203,8 +18445,7 @@ sub is_nonframeable {
$secpolicy =~ s/^\s+|\s+$//g;
$xframeop =~ s/^\s+|\s+$//g;
if (($secpolicy ne '') || ($xframeop ne '')) {
- my ($remotehost) = ($url =~ m{^(https?\://[^/?#]+)});
- $remotehost = lc($remotehost);
+ my $remotehost = $remprotocol.'://'.$remhost;
my ($origin,$protocol,$port);
if ($ENV{'SERVER_PORT'} =~/^\d+$/) {
$port = $ENV{'SERVER_PORT'};
@@ -18302,10 +18543,29 @@ sub is_nonframeable {
}
}
}
+ if ($nocache) {
+ if ($cached) {
+ my $devalidate;
+ if ($uselink && !$result) {
+ $devalidate = 1;
+ } elsif (!$uselink && $result) {
+ $devalidate = 1;
+ }
+ if ($devalidate) {
+ &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport);
+ }
+ }
+ } else {
+ if ($uselink) {
+ $result = 1;
+ } else {
+ $result = 0;
+ }
+ &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600);
+ }
return $uselink;
}
-
1;
__END__;