Return to map.pm CVS log

Up to [LON-CAPA] / rat

- When using external resources from a SSL web server, don't strip out the https://
part - otherwise constructed link (e.g., adm/wrapper/ext/example.com) is without any indication that a site uses https.
- In sequence file src is http://https:// ....
   - Remove the surplus http:// prefix when generating Edit link etc.

# The LearningOnline Network with CAPA
# routines for modyfing .sequence and .page files
#
# $Id: map.pm,v 1.13 2009/02/12 11:35:10 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/\:/\&colon;/g;
		$name=~s/\:/\&colon;/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;
	    }
	}
    }
# Put in a start resource
    my ($name,$url,$ext)=split(/\:/,$resources[$order[0]]);
    $resources[$order[0]]=$name.':'.$url.':'.$ext.':start:res';
# Make sure this has at least start and finish
    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=shift;
    my $fn=$realfn;
# unless this is forced to work from the original file, use a temporary file
# instead
    unless (shift) {
	$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,''));
}

# ------------------------------------------ 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/\&colon;/\:/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)=@_;
    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";
	if ($fn=~m{^/*uploaded/($LONCAPA::domain_re)/($LONCAPA::courseid_re)/(.*)$}) {
	    $env{'form.output'}=$outstr;
            my $result=&Apache::lonnet::finishuserfileupload($2,$1,
							     'output',$3);
	    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. ';
	    }
        }
    } else {
# -------------------------------------------- Cannot write to that file, error
        $errtext.='Map not saved: The specified path does not exist. ';
    }
    return ($errtext,$infotext);
}

1;
__END__