# The LearningOnline Network with CAPA
# routines for modyfing .sequence and .page files
#
# $Id: map.pm,v 1.16 2022/10/22 17:24:55 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
package LONCAPA::map;
use strict;
use HTML::TokeParser;
use HTML::Entities();
use Apache::lonnet;
use Apache::lonlocal;
use File::Copy;
use LONCAPA;
use vars qw(@order @resources @resparms @zombies);
# Mapread read maps into global arrays @links and @resources, determines status
# sets @order - pointer to resources in right order
# sets @resources - array with the resources with correct idx
#
sub mapread {
my ($fn)= @_;
my @links;
@resources=('');
@order=();
@resparms=();
@zombies=();
my ($outtext,$errtext)=&loadmap($fn,'');
if ($errtext) { return ($errtext,2); }
# -------------------------------------------------------------------- Read map
foreach (split(/\<\&\>/,$outtext)) {
my ($command,$number,$content)=split(/\<\:\>/,$_);
if ($command eq 'objcont') {
my ($title,$src,$ext,$type)=split(/\:/,$content);
if ($ext eq 'cond') { next; }
if ($type ne 'zombie') {
$resources[$number]=$content;
} else {
$zombies[$number]=$content;
}
}
if ($command eq 'objlinks') {
$links[$number]=$content;
}
if ($command eq 'objparms') {
if ($resparms[$number]) {
$resparms[$number].='&&&'.$content;
} else {
$resparms[$number]=$content;
}
}
}
# ------------------------------------------------------- Is this a linear map?
my @starters;
my @endings;
foreach (@links) {
if (defined($_)) {
my ($start,$end,$cond)=split(/\:/,$_);
if ((defined($starters[$start])) || (defined($endings[$end]))) {
return
(&mt('Map has branchings. Use advanced editor.'),1);
}
$starters[$start]=1;
$endings[$end]=1;
if ($cond) {
return
(&mt('Map has conditions. Use advanced editor.'),1);
}
}
}
for (my $i=1; $i<=$#resources; $i++) {
if (defined($resources[$i])) {
unless (($starters[$i]) || ($endings[$i])) {
return
(&mt('Map has unconnected resources. Use advanced editor.'),1);
}
}
}
# ---------------------------------------------- Did we just read an empty map?
if ($#resources<1) {
undef $resources[0];
$resources[1]=':::start';
$resources[2]=':::finish';
}
# -------------------------------------------------- This is a linear map, sort
my $startidx=0;
my $endidx=0;
for (my $i=0; $i<=$#resources; $i++) {
if (defined($resources[$i])) {
my ($title,$url,$ext,$type)=split(/\:/,$resources[$i]);
if ($type eq 'start') { $startidx=$i; }
if ($type eq 'finish') { $endidx=$i; }
}
}
my $k=0;
my $currentidx=$startidx;
$order[$k]=$currentidx;
for (my $i=0; $i<=$#resources; $i++) {
foreach (@links) {
my ($start,$end)=split(/\:/,$_);
if ($start==$currentidx) {
$currentidx=$end;
$k++;
$order[$k]=$currentidx;
last;
}
}
if ($currentidx==$endidx) { last; }
}
return $errtext;
}
# ---------------------------------------------- Read a map as well as possible
# Also used by the sequence handler
# Call lonsequence::attemptread to read from resource space
#
sub attemptread {
my ($fn,$unsorted)=@_;
my @links;
my @theseres;
my ($outtext,$errtext)=&loadmap($fn,'');
if ($errtext) { return @theseres }
# -------------------------------------------------------------------- Read map
my ($start,$finish);
foreach (split(/\<\&\>/,$outtext)) {
my ($command,$number,$content)=split(/\<\:\>/,$_);
if ($command eq 'objcont') {
my ($title,$src,$ext,$type)=split(/\:/,$content);
if ($type ne 'zombie' && $ext ne 'cond') {
$theseres[$number]=$content;
}
if ($type eq 'start') {
$start = $number;
}
if ($type eq 'finish') {
$finish = $number;
}
}
if ($command eq 'objlinks') {
$links[$number]=$content;
}
}
if ($unsorted) {
return @theseres;
}
# ---------------------------- attempt to flatten the map into a 'sorted' order
my %path_length = ($start => 0);
my @todo = @links;
while (@todo) {
my $link = shift(@todo);
next if (!defined($link));
my ($from,$to) = split(':',$link);
if (!exists($path_length{$from})) {
# don't know how long it takes to get to this link,
# save away to retry
push(@todo,$link);
next;
}
# already have a length, keep it
next if (exists($path_length{$to}));
$path_length{$to}=$path_length{$from}+1;
}
# invert hash so we have the ids in depth order now
my @by_depth;
while (my ($key,$value) = each(%path_length)) {
push(@{$by_depth[$value]},$key);
}
# reorder resources
my @outres;
foreach my $ids_at_depth (@by_depth) {
foreach my $id (sort(@{$ids_at_depth})) {
# skip the finish resource
next if ($id == $finish);
push(@outres, $theseres[$id]);
}
}
# make sure finish is last (in case there are cycles or bypass routes
# finish can end up with a rather short possible path)
push(@outres, $theseres[$finish]);
return @outres;
}
# ------------------------------------- Revive zombie idx or get unused number
sub getresidx {
my ($url,$residx)= @_;
my $max=1+($#resources>$#zombies?$#resources:$#zombies);
unless ($url) { return $max; }
for (my $i=0; $i<=$#zombies; $i++) {
my ($title,$src,$ext,$type)=split(/\:/,$zombies[$i]);
if ($src eq $url) {
if ($residx) {
if ($i == $residx) {
undef($zombies[$i]);
return $i;
}
} else {
undef($zombies[$i]);
return $i;
}
}
}
return $max;
}
# --------------------------------------------------------------- Make a zombie
sub makezombie {
my $idx=shift;
my ($name,$url,$ext)=split(/\:/,$resources[$idx]);
my $now=time;
$zombies[$idx]=$name.
' [('.$now.','.$env{'user.name'}.','.$env{'user.domain'}.')]:'.
$url.':'.$ext.':zombie';
}
# ----------------------------------------------------------- Paste into target
# modifies @order, @resources
sub pastetarget {
my ($after,@which)=@_;
my @insertorder=();
foreach (@which) {
if (defined($_)) {
my ($name,$url,$residx)=split(/\=/,$_);
$name=&unescape($name);
$url=&unescape($url);
if ($url) {
my $idx=&getresidx($url,$residx);
$insertorder[$#insertorder+1]=$idx;
my $ext='false';
if ($url=~/^https?\:\/\//) { $ext='true'; }
$url=~s/\:/\:/g;
$name=~s/\:/\:/g;
$resources[$idx]=$name.':'.$url.':'.$ext.':normal:res';
}
}
}
my @oldorder=splice(@order,$after);
@order=(@order,@insertorder,@oldorder);
}
# ------------------------------------------------ Get start and finish correct
# modifies @resources
sub startfinish {
# Remove all start and finish
foreach (@order) {
my ($name,$url,$ext)=split(/\:/,$resources[$_]);
if ($url=~/https?\&colon\:\/\//) { $ext='true'; }
$resources[$_]=$name.':'.$url.':'.$ext.':normal:res';
}
# Garbage collection
my $stillchange=1;
while (($#order>1) && ($stillchange)) {
$stillchange=0;
for (my $i=0;$i<=$#order;$i++) {
my ($name,$url,$ext)=split(/\:/,$resources[$order[$i]]);
unless ($url) {
# Take out empty resource
for (my $j=$i+1;$j<=$#order;$j++) {
$order[$j-1]=$order[$j];
}
$#order--;
$stillchange=1;
last;
}
}
}
# Make sure this has at least start and finish
if ($#order==-1) {
$resources[&getresidx()]='::false';
$order[0]=$#resources;
}
# Put in a start resource
my ($name,$url,$ext)=split(/\:/,$resources[$order[0]]);
$resources[$order[0]]=$name.':'.$url.':'.$ext.':start:res';
if ($#order==0) {
$resources[&getresidx()]='::false';
$order[1]=$#resources;
}
# Make the last one a finish resource
($name,$url,$ext)=split(/\:/,$resources[$order[$#order]]);
$resources[$order[$#order]]=$name.':'.$url.':'.$ext.':finish:res';
}
# ------------------------------------------------------------------- Store map
sub storemap {
my ($realfn,$useorig,$dotimeupdate) = @_;
my $fn=$realfn;
# unless this is forced to work from the original file, use a temporary file
# instead
unless ($useorig) {
$fn=$realfn.'.tmp';
unless (-e $fn) {
copy($realfn,$fn);
}
}
# store data either into tmp or real file
&startfinish();
my $output='graphdef<:>no';
my $k=1;
for (my $i=0; $i<=$#order; $i++) {
if (defined($resources[$order[$i]])) {
$output.='<&>objcont<:>'.$order[$i].'<:>'.$resources[$order[$i]];
}
if (defined($resparms[$order[$i]])) {
foreach (split('&&&',$resparms[$order[$i]])) {
if ($_) {
$output.='<&>objparms<:>'.$order[$i].'<:>'.$_;
}
}
}
if (defined($order[$i+1])) {
if (defined($resources[$order[$i+1]])) {
$output.='<&>objlinks<:>'.$k.'<:>'.
$order[$i].':'.$order[$i+1].':0';
$k++;
}
}
}
for (my $i=0; $i<=$#zombies; $i++) {
if (defined($zombies[$i])) {
$output.='<&>objcont<:>'.$i.'<:>'.$zombies[$i];
}
}
$output=~s/http\&colon\;\/\///g;
$env{'form.output'}=$output;
return &loadmap($fn,&savemap($fn,'',$dotimeupdate));
}
# ------------------------------------------ Store and get parameters in global
sub storeparameter {
my ($to,$name,$value,$ptype)=@_;
my $newentry='';
my $nametype='';
foreach (split('&&&',$resparms[$to])) {
my ($thistype,$thisname,$thisvalue)=split('___',$_);
if ($thisname) {
unless ($thisname eq $name) {
$newentry.=$_.'&&&';
} else {
$nametype=$thistype;
}
}
}
unless ($ptype) { $ptype=$nametype; }
unless ($ptype) { $ptype='string'; }
$newentry.=$ptype.'___'.$name.'___'.$value;
$resparms[$to]=$newentry;
}
sub delparameter {
my ($to,$name)=@_;
my $newentry='';
my $nametype='';
foreach (split('&&&',$resparms[$to])) {
my ($thistype,$thisname,$thisvalue)=split('___',$_);
if ($thisname) {
unless ($thisname eq $name) {
$newentry.=$_.'&&&';
}
}
}
$resparms[$to]=$newentry;
}
sub getparameter {
my ($to,$name)=@_;
my $value=undef;
my $ptype=undef;
foreach (split('&&&',$resparms[$to])) {
my ($thistype,$thisname,$thisvalue)=split('___',$_);
if ($thisname eq $name) {
$value=$thisvalue;
$ptype=$thistype;
}
}
return ($value,$ptype);
}
# ------------------------------------------------------------- From RAT to XML
sub qtescape {
my $str=shift;
$str=~s/\:/\:/g;
$str=~s/\&\#58\;/\:/g;
$str=~s/\&\#39\;/\'/g;
$str=~s/\&\#44\;/\,/g;
$str=~s/\&\#34\;/\"/g;
return $str;
}
# ------------------------------------------------------------- From XML to RAT
sub qtunescape {
my $str=shift;
$str=~s/\:/\&colon\;/g;
$str=~s/\'/\&\#39\;/g;
$str=~s/\,/\&\#44\;/g;
$str=~s/\"/\&\#34\;/g;
return $str;
}
# --------------------------------------------------------- Loads map from disk
sub loadmap {
my ($fn,$errtext,$infotext)=@_;
if ($errtext) { return('',$errtext); }
my $outstr='';
my @obj=();
my @links=();
my $instr='';
if ($fn=~/^\/*uploaded\//) {
$instr=&Apache::lonnet::getfile($fn);
} elsif (-e $fn) {
my @content=();
{
open(my $fh,"<$fn");
@content=<$fh>;
}
$instr=join('',@content);
}
if ($instr eq -2) {
$errtext.='Map not loaded: An error occurred while trying to load the map.';
} elsif ($instr eq '-1') {
# Map doesn't exist
} elsif ($instr) {
my $parser = HTML::TokeParser->new(\$instr);
my $token;
my $graphmode=0;
$fn=~/\.(\w+)$/;
$outstr="mode<:>$1";
while ($token = $parser->get_token) {
if ($token->[0] eq 'S') {
if ($token->[1] eq 'map') {
$graphmode=($token->[2]->{'mode'} eq 'rat/graphical');
} elsif ($token->[1] eq 'resource') {
# -------------------------------------------------------------------- Resource
$outstr.='<&>objcont';
if (defined($token->[2]->{'id'})) {
$outstr.='<:>'.$token->[2]->{'id'};
if ($obj[$token->[2]->{'id'}]==1) {
$errtext.='Error: multiple use of ID '.
$token->[2]->{'id'}.'. ';
}
$obj[$token->[2]->{'id'}]=1;
} else {
my $i=1;
while (($i<=$#obj) && ($obj[$i]!=0)) { $i++; }
$outstr.='<:>'.$i;
$obj[$i]=1;
}
$outstr.='<:>';
$outstr.=qtunescape($token->[2]->{'title'}).":";
$outstr.=qtunescape($token->[2]->{'src'}).":";
if ($token->[2]->{'external'} eq 'true') {
$outstr.='true:';
} else {
$outstr.='false:';
}
if (defined($token->[2]->{'type'})) {
$outstr.=$token->[2]->{'type'}.':';
} else {
$outstr.='normal:';
}
if ($token->[2]->{'type'} ne 'zombie') {
$outstr.='res';
} else {
$outstr.='zombie';
}
} elsif ($token->[1] eq 'condition') {
# ------------------------------------------------------------------- Condition
$outstr.='<&>objcont';
if (defined($token->[2]->{'id'})) {
$outstr.='<:>'.$token->[2]->{'id'};
if ($obj[$token->[2]->{'id'}]==1) {
$errtext.='Error: multiple use of ID '.
$token->[2]->{'id'}.'. ';
}
$obj[$token->[2]->{'id'}]=1;
} else {
my $i=1;
while (($i<=$#obj) && ($obj[$i]!=0)) { $i++; }
$outstr.='<:>'.$i;
$obj[$i]=1;
}
$outstr.='<:>';
$outstr.=qtunescape($token->[2]->{'value'}).':';
if (defined($token->[2]->{'type'})) {
$outstr.=$token->[2]->{'type'}.':';
} else {
$outstr.='normal:';
}
$outstr.='cond';
} elsif ($token->[1] eq 'link') {
# ----------------------------------------------------------------------- Links
$outstr.='<&>objlinks';
if (defined($token->[2]->{'index'})) {
if ($links[$token->[2]->{'index'}]) {
$errtext.='Error: multiple use of link index '.
$token->[2]->{'index'}.'. ';
}
$outstr.='<:>'.$token->[2]->{'index'};
$links[$token->[2]->{'index'}]=1;
} else {
my $i=1;
while (($i<=$#links) && ($links[$i]==1)) { $i++; }
$outstr.='<:>'.$i;
$links[$i]=1;
}
$outstr.='<:>'.$token->[2]->{'from'}.
':'.$token->[2]->{'to'};
if (defined($token->[2]->{'condition'})) {
$outstr.=':'.$token->[2]->{'condition'};
} else {
$outstr.=':0';
}
# ------------------------------------------------------------------- Parameter
} elsif ($token->[1] eq 'param') {
$outstr.='<&>objparms<:>'.$token->[2]->{'to'}.'<:>'.
$token->[2]->{'type'}.'___'.$token->[2]->{'name'}.
'___'.$token->[2]->{'value'};
} elsif ($graphmode) {
# --------------------------------------------- All other tags (graphical only)
$outstr.='<&>'.$token->[1];
if (defined($token->[2]->{'index'})) {
$outstr.='<:>'.$token->[2]->{'index'};
if ($token->[1] eq 'obj') {
$obj[$token->[2]->{'index'}]=2;
}
}
$outstr.='<:>'.$token->[2]->{'value'};
}
}
}
} else {
$errtext.='Map not loaded: The file does not exist. ';
}
return($outstr,$errtext,$infotext);
}
# ----------------------------------------------------------- Saves map to disk
sub savemap {
my ($fn,$errtext,$dotimeupdate)=@_;
my $infotext='';
my %alltypes;
my %allvalues;
if (($fn=~/\.sequence(\.tmp)*$/) ||
($fn=~/\.page(\.tmp)*$/)) {
# ------------------------------------------------------------- Deal with input
my @tags=split(/<&>/,$env{'form.output'});
my $outstr='';
my $graphdef=0;
if ($tags[0] eq 'graphdef<:>yes') {
$outstr='<map mode="rat/graphical">'."\n";
$graphdef=1;
} else {
$outstr="<map>\n";
}
foreach (@tags) {
my @parts=split(/<:>/,$_);
if ($parts[0] eq 'objcont') {
my @comp=split(/:/,$parts[$#parts]);
# --------------------------------------------------------------- Logical input
if (($comp[$#comp] eq 'res') || ($comp[$#comp] eq 'zombie')) {
$comp[0]=qtescape($comp[0]);
$comp[0] = &HTML::Entities::encode($comp[0],'&<>"');
$comp[1]=qtescape($comp[1]);
if ($comp[2] eq 'true') {
if ($comp[1]!~/^http\:\/\//) {
$comp[1]='http://'.$comp[1];
}
$comp[1].='" external="true';
} else {
if ($comp[1]=~/^http\:\/\//) {
$comp[1]=~s/^http\:\/\/[^\/]*\//\//;
}
}
$outstr.='<resource id="'.$parts[1].'" src="'
.$comp[1].'"';
if (($comp[3] ne '') && ($comp[3] ne 'normal')) {
$outstr.=' type="'.$comp[3].'"';
}
if ($comp[0] ne '') {
$outstr.=' title="'.$comp[0].'"';
}
$outstr.=" />\n";
} elsif ($comp[$#comp] eq 'cond') {
$outstr.='<condition id="'.$parts[1].'"';
if (($comp[1] ne '') && ($comp[1] ne 'normal')) {
$outstr.=' type="'.$comp[1].'"';
}
$outstr.=' value="'.qtescape($comp[0]).'"';
$outstr.=" />\n";
}
} elsif ($parts[0] eq 'objlinks') {
my @comp=split(/:/,$parts[$#parts]);
$outstr.='<link';
$outstr.=' from="'.$comp[0].'"';
$outstr.=' to="'.$comp[1].'"';
if (($comp[2] ne '') && ($comp[2]!=0)) {
$outstr.=' condition="'.$comp[2].'"';
}
$outstr.=' index="'.$parts[1].'"';
$outstr.=" />\n";
} elsif ($parts[0] eq 'objparms') {
undef %alltypes;
undef %allvalues;
foreach (split(/:/,$parts[$#parts])) {
my ($type,$name,$value)=split(/\_\_\_/,$_);
$alltypes{$name}=$type;
$allvalues{$name}=$value;
}
foreach (keys %allvalues) {
if ($allvalues{$_} ne '') {
$outstr.='<param to="'.$parts[1].'" type="'
.$alltypes{$_}.'" name="'.$_
.'" value="'.$allvalues{$_}.'" />'
."\n";
}
}
} elsif (($parts[0] ne '') && ($graphdef)) {
# ------------------------------------------------------------- Graphical input
$outstr.='<'.$parts[0];
if ($#parts==2) {
$outstr.=' index="'.$parts[1].'"';
}
$outstr.=' value="'.qtescape($parts[$#parts]).'" />'."\n";
}
}
$outstr.="</map>\n";
my ($cdom,$cnum,$mapname);
if ($fn=~m{^/*uploaded/($LONCAPA::domain_re)/($LONCAPA::courseid_re)/(.*)$}) {
($cdom,$cnum,$mapname) = ($1,$2,$3);
$env{'form.output'}=$outstr;
my $result=&Apache::lonnet::finishuserfileupload($cnum,$cdom,
'output',$mapname);
if ($result != m|^/uploaded/|) {
$errtext.='Map not saved: A network error occurred when trying to save the map. ';
}
} else {
if (open(my $fh,">$fn")) {
print $fh $outstr;
$infotext.="Map saved as $fn. ";
} else {
$errtext.='Could not write file '.$fn.'. Map not saved. ';
}
}
if ($dotimeupdate) {
unless ($errtext) {
if ($env{'request.course.id'}) {
if (($cdom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) &&
($cnum eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
($mapname =~ /^supplemental(|_\d+)\.sequence$/)) {
&Apache::lonnet::update_supp_caches($cdom,$cnum);
} else {
my $now = time;
&Apache::lonnet::put('environment',{'internal.contentchange' => $now},
$env{'course.'.$env{'request.course.id'}.'.domain'},
$env{'course.'.$env{'request.course.id'}.'.num'});
&Apache::lonnet::appenv(
{'course.'.$env{'request.course.id'}.'.internal.contentchange' => $now});
&Apache::lonnet::do_cache_new('crschange',$env{'request.course.id'},$now,600);
}
}
}
}
} else {
# -------------------------------------------- Cannot write to that file, error
$errtext.='Map not saved: The specified path does not exist. ';
}
return ($errtext,$infotext);
}
1;
__END__
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to map.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / rat