--- loncom/interface/loncommon.pm 2020/06/09 21:32:32 1.1343
+++ loncom/interface/loncommon.pm 2021/02/18 15:41:10 1.1354
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1343 2020/06/09 21:32:32 raeburn Exp $
+# $Id: loncommon.pm,v 1.1354 2021/02/18 15:41:10 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -4893,6 +4893,59 @@ sub get_student_view_with_retries {
}
}
+sub css_links {
+ my ($currsymb,$level) = @_;
+ my ($links,@symbs,%cssrefs,%httpref);
+ if ($level eq 'map') {
+ my $navmap = Apache::lonnavmaps::navmap->new();
+ if (ref($navmap)) {
+ my ($map,undef,$url)=&Apache::lonnet::decode_symb($currsymb);
+ my @resources = $navmap->retrieveResources($map,sub { $_[0]->is_problem() },0,0);
+ foreach my $res (@resources) {
+ if (ref($res) && $res->symb()) {
+ push(@symbs,$res->symb());
+ }
+ }
+ }
+ } else {
+ @symbs = ($currsymb);
+ }
+ foreach my $symb (@symbs) {
+ my $css_href = &Apache::lonnet::EXT('resource.0.cssfile',$symb);
+ if ($css_href =~ /\S/) {
+ unless ($css_href =~ m{https?://}) {
+ my $url = (&Apache::lonnet::decode_symb($symb))[-1];
+ my $proburl = &Apache::lonnet::clutter($url);
+ my ($probdir) = ($proburl =~ m{(.+)/[^/]+$});
+ unless ($css_href =~ m{^/}) {
+ $css_href = &Apache::lonnet::hreflocation($probdir,$css_href);
+ }
+ if ($css_href =~ m{^/(res|uploaded)/}) {
+ unless (($httpref{'httpref.'.$css_href}) ||
+ (&Apache::lonnet::is_on_map($css_href))) {
+ my $thisurl = $proburl;
+ if ($env{'httpref.'.$proburl}) {
+ $thisurl = $env{'httpref.'.$proburl};
+ }
+ $httpref{'httpref.'.$css_href} = $thisurl;
+ }
+ }
+ }
+ $cssrefs{$css_href} = 1;
+ }
+ }
+ if (keys(%httpref)) {
+ &Apache::lonnet::appenv(\%httpref);
+ }
+ if (keys(%cssrefs)) {
+ foreach my $css_href (keys(%cssrefs)) {
+ next unless ($css_href =~ m{^(/res/|/uploaded/|https?://)});
+ $links .= '<link rel="stylesheet" type="text/css" href="'.$css_href.'" />'."\n";
+ }
+ }
+ return $links;
+}
+
=pod
=item * &get_student_answers()
@@ -5148,13 +5201,13 @@ sub findallcourses {
###############################################
sub blockcheck {
- my ($setters,$activity,$uname,$udom,$url,$is_course) = @_;
+ my ($setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_;
if (defined($udom) && defined($uname)) {
# If uname and udom are for a course, check for blocks in the course.
if (($is_course) || (&Apache::lonnet::is_course($udom,$uname))) {
my ($startblock,$endblock,$triggerblock) =
- &get_blocks($setters,$activity,$udom,$uname,$url);
+ &get_blocks($setters,$activity,$udom,$uname,$url,$symb,$caller);
return ($startblock,$endblock,$triggerblock);
}
} else {
@@ -5172,7 +5225,8 @@ sub blockcheck {
if (($activity eq 'boards' || $activity eq 'chat' ||
$activity eq 'groups' || $activity eq 'printout' ||
- $activity eq 'reinit' || $activity eq 'alert') &&
+ $activity eq 'search' || $activity eq 'reinit' ||
+ $activity eq 'alert') &&
($env{'request.course.id'})) {
foreach my $key (keys(%live_courses)) {
if ($key ne $env{'request.course.id'}) {
@@ -5282,7 +5336,7 @@ sub blockcheck {
# of specified user, unless user has 'evb' privilege.
my ($start,$end,$trigger) =
- &get_blocks($setters,$activity,$cdom,$cnum,$url);
+ &get_blocks($setters,$activity,$cdom,$cnum,$url,$symb,$caller);
if (($start != 0) &&
(($startblock == 0) || ($startblock > $start))) {
$startblock = $start;
@@ -5302,7 +5356,7 @@ sub blockcheck {
}
sub get_blocks {
- my ($setters,$activity,$cdom,$cnum,$url) = @_;
+ my ($setters,$activity,$cdom,$cnum,$url,$symb,$caller) = @_;
my $startblock = 0;
my $endblock = 0;
my $triggerblock = '';
@@ -5315,7 +5369,13 @@ sub get_blocks {
my $now = time;
my %commblocks = &Apache::lonnet::get_comm_blocks($cdom,$cnum);
if ($activity eq 'docs') {
- @blockers = &Apache::lonnet::has_comm_blocking('bre',undef,$url,\%commblocks);
+ my ($blocked,$nosymbcache,$noenccheck);
+ if (($caller eq 'blockedaccess') || ($caller eq 'blockingstatus')) {
+ $blocked = 1;
+ $nosymbcache = 1;
+ $noenccheck = 1;
+ }
+ @blockers = &Apache::lonnet::has_comm_blocking('bre',$symb,$url,$nosymbcache,$noenccheck,$blocked,\%commblocks);
foreach my $block (@blockers) {
if ($block =~ /^firstaccess____(.+)$/) {
my $item = $1;
@@ -5443,12 +5503,12 @@ sub parse_block_record {
}
sub blocking_status {
- my ($activity,$uname,$udom,$url,$is_course) = @_;
+ my ($activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_;
my %setters;
# check for active blocking
my ($startblock,$endblock,$triggerblock) =
- &blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course);
+ &blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller);
my $blocked = 0;
if ($startblock && $endblock) {
$blocked = 1;
@@ -5459,12 +5519,17 @@ sub blocking_status {
# build a link to a popup window containing the details
my $querystring = "?activity=$activity";
-# $uname and $udom decide whose portfolio the user is trying to look at
- if (($activity eq 'port') || ($activity eq 'passwd')) {
+# $uname and $udom decide whose portfolio (or information page) the user is trying to look at
+ if (($activity eq 'port') || ($activity eq 'about') || ($activity eq 'passwd')) {
$querystring .= "&udom=$udom" if ($udom =~ /^$match_domain$/);
$querystring .= "&uname=$uname" if ($uname =~ /^$match_username$/);
} elsif ($activity eq 'docs') {
- $querystring .= '&url='.&HTML::Entities::encode($url,'&"');
+ my $showurl = &Apache::lonenc::check_encrypt($url);
+ $querystring .= '&url='.&HTML::Entities::encode($showurl,'\'&"<>');
+ if ($symb) {
+ my $showsymb = &Apache::lonenc::check_encrypt($symb);
+ $querystring .= '&symb='.&HTML::Entities::encode($showsymb,'\'&"<>');
+ }
}
my $output .= <<'END_MYBLOCK';
@@ -5489,10 +5554,16 @@ END_MYBLOCK
$text = &mt('Printing Blocked');
} elsif ($activity eq 'passwd') {
$text = &mt('Password Changing Blocked');
+ } elsif ($activity eq 'grades') {
+ $text = &mt('Gradebook Blocked');
+ } elsif ($activity eq 'search') {
+ $text = &mt('Search Blocked');
} elsif ($activity eq 'alert') {
$text = &mt('Checking Critical Messages Blocked');
} elsif ($activity eq 'reinit') {
$text = &mt('Checking Course Update Blocked');
+ } elsif ($activity eq 'about') {
+ $text = &mt('Access to User Information Pages Blocked');
}
$output .= <<"END_BLOCK";
<div class='$class'>
@@ -5521,7 +5592,8 @@ sub check_ip_acc {
($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) {
$ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip;
} else {
- $ip = $ENV{'REMOTE_ADDR'} || $env{'request.host'} || $clientip;
+ my $remote_ip = &Apache::lonnet::get_requestor_ip();
+ $ip = $remote_ip || $env{'request.host'} || $clientip;
}
my $name;
@@ -8527,10 +8599,17 @@ ADDMETA
unless (&Apache::lonnet::allowed('mau',$dom_in_use)) {
my %domdefs = &Apache::lonnet::get_domain_defaults($dom_in_use);
my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
- my $offload;
+ my ($offload,$offloadoth);
if (ref($domdefs{'offloadnow'}) eq 'HASH') {
if ($domdefs{'offloadnow'}{$lonhost}) {
$offload = 1;
+ if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) &&
+ (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
+ unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
+ $offloadoth = 1;
+ $dom_in_use = $env{'user.domain'};
+ }
+ }
}
}
unless ($offload) {
@@ -8540,6 +8619,7 @@ ADDMETA
(!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) {
unless (&Apache::lonnet::shared_institution($env{'user.domain'})) {
$offload = 1;
+ $offloadoth = 1;
$dom_in_use = $env{'user.domain'};
}
}
@@ -8548,6 +8628,12 @@ ADDMETA
}
if ($offload) {
my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use);
+ if (($newserver eq '') && ($offloadoth)) {
+ my @domains = &Apache::lonnet::current_machine_domains();
+ if (($dom_in_use ne '') && (!grep(/^\Q$dom_in_use\E$/,@domains))) {
+ ($newserver) = &Apache::lonnet::choose_server($dom_in_use);
+ }
+ }
if (($newserver) && ($newserver ne $lonhost)) {
my $numsec = 5;
my $timeout = $numsec * 1000;
@@ -8561,7 +8647,7 @@ ADDMETA
}
if ($locknum) {
my @lockinfo = sort(values(%locks));
- $msg = &mt('Once the following tasks are complete: ')."\n".
+ $msg = &mt('Once the following tasks are complete:')." \n".
join(", ",sort(values(%locks)))."\n";
if (&show_course()) {
$msg .= &mt('your session will be transferred to a different server, after you click "Courses".');
@@ -15868,7 +15954,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') {
@@ -15876,16 +15963,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'}) &&
@@ -15974,20 +16083,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 = '<br />'."\n";
if ($context eq 'auto') {
$linefeed = "\n";
@@ -15996,18 +16119,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 = '<span class="LC_error">'.$clonemsg.'</span>';
- }
- }
- $outcome .= $clonemsg.$linefeed;
-
+ ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed);
if (!$can_clone) {
- return (0,$outcome);
+ return (0,$outcome,$clonemsgref);
}
}
@@ -16030,15 +16146,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);
}
#
@@ -16047,24 +16168,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 = '<span class="LC_success">'.$clonemsg.'</span>';
- }
- $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'},$args->{'crscode'});
+ 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
@@ -16395,7 +16529,7 @@ sub construct_course {
('resourcedata',\%storecontent,$$crsudom,$$crsunum);
}
- return (1,$outcome);
+ return (1,$outcome,\@clonemsg);
}
sub make_unique_code {
@@ -16684,6 +16818,7 @@ sub init_user_environment {
# --------------------------------------------------------- Write first profile
{
+ my $ip = &Apache::lonnet::get_requestor_ip($r);
my %initial_env =
("user.name" => $username,
"user.domain" => $domain,
@@ -16702,7 +16837,7 @@ sub init_user_environment {
"request.course.sec" => '',
"request.role" => 'cm',
"request.role.adv" => $env{'user.adv'},
- "request.host" => $ENV{'REMOTE_ADDR'},);
+ "request.host" => $ip,);
if ($form->{'localpath'}) {
$initial_env{"browser.localpath"} = $form->{'localpath'};
@@ -18041,11 +18176,12 @@ sub create_recaptcha {
sub check_recaptcha {
my ($privkey,$version) = @_;
my $captcha_chk;
+ my $ip = &Apache::lonnet::get_requestor_ip();
if ($version >= 2) {
my %info = (
secret => $privkey,
response => $env{'form.g-recaptcha-response'},
- remoteip => $ENV{'REMOTE_ADDR'},
+ remoteip => $ip,
);
my $request=new HTTP::Request('POST','https://www.google.com/recaptcha/api/siteverify');
$request->content(join('&',map {
@@ -18068,7 +18204,7 @@ sub check_recaptcha {
my $captcha_result =
$captcha->check_answer(
$privkey,
- $ENV{'REMOTE_ADDR'},
+ $ip,
$env{'form.recaptcha_challenge_field'},
$env{'form.recaptcha_response_field'},
);
@@ -18201,24 +18337,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);
@@ -18226,9 +18375,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);