Annotation of rat/map.pm, revision 1.1

1.1     ! albertel    1: # The LearningOnline Network with CAPA
        !             2: # routines for modyfing .sequence and .page files
        !             3: #
        !             4: # $Id: loncommon.pm,v 1.444 2006/08/11 22:00:07 albertel Exp $
        !             5: #
        !             6: # Copyright Michigan State University Board of Trustees
        !             7: #
        !             8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
        !             9: #
        !            10: # LON-CAPA is free software; you can redistribute it and/or modify
        !            11: # it under the terms of the GNU General Public License as published by
        !            12: # the Free Software Foundation; either version 2 of the License, or
        !            13: # (at your option) any later version.
        !            14: #
        !            15: # LON-CAPA is distributed in the hope that it will be useful,
        !            16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
        !            17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
        !            18: # GNU General Public License for more details.
        !            19: #
        !            20: # You should have received a copy of the GNU General Public License
        !            21: # along with LON-CAPA; if not, write to the Free Software
        !            22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
        !            23: #
        !            24: # /home/httpd/html/adm/gpl.txt
        !            25: #
        !            26: # http://www.lon-capa.org/
        !            27: #
        !            28: 
        !            29: package LONCAPA::map;
        !            30: 
        !            31: use HTML::TokeParser;
        !            32: use Apache::lonnet;
        !            33: use Apache::lonlocal;
        !            34: use File::Copy;
        !            35: use LONCAPA;
        !            36: 
        !            37: use vars qw(@order @resources @resparms @zombies);
        !            38: 
        !            39: # Mapread read maps into global arrays @links and @resources, determines status
        !            40: # sets @order - pointer to resources in right order
        !            41: # sets @resources - array with the resources with correct idx
        !            42: #
        !            43: sub mapread {
        !            44:     my ($fn)= @_;
        !            45: 
        !            46:     my @links;
        !            47: 
        !            48:     @resources=('');
        !            49:     @order=();
        !            50:     @resparms=();
        !            51:     @zombies=();
        !            52: 
        !            53:     my ($outtext,$errtext)=&loadmap($fn,'');
        !            54:     if ($errtext) { return ($errtext,2); }
        !            55: 
        !            56: # -------------------------------------------------------------------- Read map
        !            57:     foreach (split(/\<\&\>/,$outtext)) {
        !            58: 	my ($command,$number,$content)=split(/\<\:\>/,$_);
        !            59:         if ($command eq 'objcont') {
        !            60: 	    my ($title,$src,$ext,$type)=split(/\:/,$content);
        !            61: 	    if ($ext eq 'cond') { next; }
        !            62: 	    if ($type ne 'zombie') {
        !            63: 		$resources[$number]=$content;
        !            64: 	    } else {
        !            65: 		$zombies[$number]=$content;
        !            66: 	    }
        !            67:         }
        !            68:         if ($command eq 'objlinks') {
        !            69:             $links[$number]=$content;
        !            70:         }
        !            71:         if ($command eq 'objparms') {
        !            72: 	    if ($resparms[$number]) {
        !            73: 		$resparms[$number].='&&&'.$content;
        !            74: 	    } else {
        !            75: 		$resparms[$number]=$content;
        !            76: 	    }
        !            77:         }
        !            78:     }
        !            79: # ------------------------------------------------------- Is this a linear map?
        !            80:     my @starters;
        !            81:     my @endings;
        !            82: 
        !            83:     foreach (@links) {
        !            84:         if (defined($_)) {
        !            85: 	    my ($start,$end,$cond)=split(/\:/,$_);
        !            86:             if ((defined($starters[$start])) || (defined($endings[$end]))) { 
        !            87: 		return
        !            88: 		    (&mt('Map has branchings. Use advanced editor.'),1);
        !            89:             }
        !            90: 	    $starters[$start]=1;
        !            91: 	    $endings[$end]=1;
        !            92: 	    if ($cond) {
        !            93: 		return
        !            94: 		    (&mt('Map has conditions. Use advanced editor.'),1);
        !            95:             }
        !            96: 	}
        !            97:     }
        !            98: 
        !            99:     for (my $i=1; $i<=$#resources; $i++) {
        !           100:         if (defined($resources[$i])) {
        !           101: 	    unless (($starters[$i]) || ($endings[$i])) {
        !           102:                 return
        !           103: 		    (&mt('Map has unconnected resources. Use advanced editor.'),1);
        !           104:             }
        !           105:         }
        !           106:     }
        !           107: # ---------------------------------------------- Did we just read an empty map?
        !           108:     if ($#resources<1) {
        !           109:         undef $resources[0];
        !           110: 	$resources[1]=':::start';
        !           111:         $resources[2]=':::finish';
        !           112:     }
        !           113: # -------------------------------------------------- This is a linear map, sort
        !           114: 
        !           115:     my $startidx=0;
        !           116:     my $endidx=0;
        !           117:     for (my $i=0; $i<=$#resources; $i++) {
        !           118:         if (defined($resources[$i])) {
        !           119:             my ($title,$url,$ext,$type)=split(/\:/,$resources[$i]);
        !           120: 	    if ($type eq 'start') { $startidx=$i; }
        !           121:             if ($type eq 'finish') { $endidx=$i; }
        !           122:         }
        !           123:     }
        !           124:     my $k=0;
        !           125:     my $currentidx=$startidx;
        !           126:     $order[$k]=$currentidx;
        !           127:     for (my $i=0; $i<=$#resources; $i++) {
        !           128:         foreach (@links) {
        !           129: 	    my ($start,$end)=split(/\:/,$_);
        !           130:             if ($start==$currentidx) {
        !           131: 		$currentidx=$end;
        !           132:                 $k++;
        !           133:                 $order[$k]=$currentidx;
        !           134:                 last;
        !           135:             }
        !           136:         }
        !           137:         if ($currentidx==$endidx) { last; }
        !           138:     }
        !           139:     return $errtext;
        !           140: }
        !           141: 
        !           142: # ---------------------------------------------- Read a map as well as possible
        !           143: # Also used by the sequence handler
        !           144: # Call lonsequence::attemptread to read from resource space
        !           145: #
        !           146: sub attemptread {
        !           147:     my $fn=shift;
        !           148: 
        !           149:     my @links;
        !           150:     my @theseres;
        !           151: 
        !           152:     my ($outtext,$errtext)=&loadmap($fn,'');
        !           153:     if ($errtext) { return @theseres }
        !           154: 
        !           155: # -------------------------------------------------------------------- Read map
        !           156:     foreach (split(/\<\&\>/,$outtext)) {
        !           157: 	my ($command,$number,$content)=split(/\<\:\>/,$_);
        !           158:         if ($command eq 'objcont') {
        !           159: 	    my ($title,$src,$ext,$type)=split(/\:/,$content);
        !           160: 	    unless ($type eq 'zombie') {
        !           161: 		$theseres[$number]=$content;
        !           162: 	    }
        !           163:         }
        !           164:         if ($command eq 'objlinks') {
        !           165:             $links[$number]=$content;
        !           166:         }
        !           167:     }
        !           168: 
        !           169: # --------------------------------------------------------------- Sort, sort of
        !           170: 
        !           171:     my @objsort;
        !           172: 
        !           173:     for (my $k=1;$k<=$#theseres;$k++) {
        !           174: 	if (defined($theseres[$k])) {
        !           175: 	    $objsort[$#objsort+1]=$k;
        !           176: 	}
        !           177:     }
        !           178: 
        !           179:     for (my $k=1;$k<=$#links;$k++) {
        !           180: 	if (defined($links[$k])) {
        !           181: 	    my @data1=split(/\:/,$links[$k]);
        !           182: 	    my $kj=-1;
        !           183: 	    for (my $j=0;$j<=$#objsort;$j++) {
        !           184: 		if ((split(/\:/,$objsort[$j]))[0]==$data1[0]) {
        !           185: 		    $kj=$j;
        !           186: 		}
        !           187: 	    }
        !           188: 	    if ($kj!=-1) { $objsort[$kj].=':'.$data1[1]; }
        !           189: 	}
        !           190:     }
        !           191:     for (my $k=0;$k<=$#objsort;$k++) {
        !           192: 	for (my $j=0;$j<=$#objsort;$j++) {
        !           193: 	    if ($k!=$j) {
        !           194: 		my @data1=split(/\:/,$objsort[$k]);
        !           195: 		my @data2=split(/\:/,$objsort[$j]);
        !           196: 		my $dol=$#data1+1;
        !           197: 		my $dtl=$#data2+1;
        !           198: 		if ($dol+$dtl<1000) {
        !           199: 		    for (my $kj=1;$kj<$dol;$kj++) {
        !           200: 			if ($data1[$kj]==$data2[0]) {
        !           201: 			    for ($ij=1;$ij<$dtl;$ij++) {
        !           202: 				$data1[$#data1+1]=$data2[$ij];
        !           203: 			    }
        !           204: 			}
        !           205: 		    }
        !           206: 		    for (my $kj=1;$kj<$dtl;$kj++) {
        !           207: 			if ($data2[$kj]==$data1[0]) {
        !           208: 			    for ($ij=1;$ij<$dol;$ij++) {
        !           209: 				$data2[$#data2+1]=$data1[$ij];
        !           210: 			    }
        !           211: 			}
        !           212: 		    }
        !           213: 		    $objsort[$k]=join(':',@data1);
        !           214: 		    $objsort[$j]=join(':',@data2);
        !           215: 		}
        !           216: 	    }
        !           217: 	} 
        !           218:     }
        !           219: # ---------------------------------------------------------------- Now sort out
        !           220: 
        !           221:     @objsort=sort {
        !           222: 	my @data1=split(/\:/,$a);
        !           223: 	my @data2=split(/\:/,$b);
        !           224: 	my $rvalue=0;
        !           225: 	for (my $k=1;$k<=$#data1;$k++) {
        !           226: 	    if ($data1[$k]==$data2[0]) { $rvalue--; }
        !           227: 	}
        !           228: 	for (my $k=1;$k<=$#data2;$k++) {
        !           229: 	    if ($data2[$k]==$data1[0]) { $rvalue++; }
        !           230: 	}
        !           231: 	if ($rvalue==0) { $rvalue=$#data2-$#data1; }
        !           232: 	$rvalue;
        !           233:     } @objsort;
        !           234: 
        !           235:     my @outres;
        !           236: 
        !           237:     for ($k=0;$k<=$#objsort;$k++) {
        !           238: 	$outres[$k]=$theseres[(split(/\:/,$objsort[$k]))[0]];
        !           239:     }
        !           240: 
        !           241:     return @outres;
        !           242: }
        !           243: 
        !           244: # ------------------------------------- Revive zombie idx or get unused number
        !           245: 
        !           246: sub getresidx {
        !           247:     my $url=shift;
        !           248:     my $max=1+($#resources>$#zombies?$#resources:$#zombies);
        !           249:     unless ($url) { return $max; }
        !           250:     for (my $i=0; $i<=$#zombies; $i++) {
        !           251: 	my ($title,$src,$ext,$type)=split(/\:/,$zombies[$i]);
        !           252: 	if ($src eq $url) {
        !           253: 	    undef($zombies[$i]);
        !           254: 	    return $i;
        !           255: 	}
        !           256:     }
        !           257:     return $max;
        !           258: }
        !           259: 
        !           260: # --------------------------------------------------------------- Make a zombie
        !           261: 
        !           262: sub makezombie {
        !           263:     my $idx=shift;
        !           264:     my ($name,$url,$ext)=split(/\:/,$resources[$idx]);
        !           265:     my $now=time;
        !           266:     $zombies[$idx]=$name.
        !           267: 	' [('.$now.','.$env{'user.name'}.','.$env{'user.domain'}.')]:'.
        !           268: 	$url.':'.$ext.':zombie';
        !           269: }
        !           270: 
        !           271: # ----------------------------------------------------------- Paste into target
        !           272: # modifies @order, @resources
        !           273: 
        !           274: sub pastetarget {
        !           275:     my ($after,@which)=@_;
        !           276:     my @insertorder=();
        !           277:     foreach (@which) {
        !           278:         if (defined($_)) {
        !           279: 	    my ($name,$url)=split(/\=/,$_);
        !           280:             $name=&unescape($name);
        !           281:             $url=&unescape($url);
        !           282:             if ($url) {
        !           283: 		my $idx=&getresidx($url);
        !           284: 		$insertorder[$#insertorder+1]=$idx;
        !           285: 		my $ext='false';
        !           286: 		if ($url=~/^http\:\/\//) { $ext='true'; }
        !           287: 		$url=~s/\:/\&colon;/g;
        !           288: 		$name=~s/\:/\&colon;/g;
        !           289: 		$resources[$idx]=$name.':'.$url.':'.$ext.':normal:res';
        !           290: 	    }
        !           291:         }
        !           292:     }
        !           293:     my @oldorder=splice(@order,$after);
        !           294:     @order=(@order,@insertorder,@oldorder);
        !           295: }
        !           296: 
        !           297: # ------------------------------------------------ Get start and finish correct
        !           298: # modifies @resources
        !           299: 
        !           300: sub startfinish {
        !           301: # Remove all start and finish
        !           302:     foreach (@order) {
        !           303: 	my ($name,$url,$ext)=split(/\:/,$resources[$_]);
        !           304:         if ($url=~/http\&colon\:\/\//) { $ext='true'; }
        !           305:         $resources[$_]=$name.':'.$url.':'.$ext.':normal:res';
        !           306:     }
        !           307: # Garbage collection
        !           308:     my $stillchange=1;
        !           309:     while (($#order>1) && ($stillchange)) {
        !           310: 	$stillchange=0;
        !           311: 	for (my $i=0;$i<=$#order;$i++) {
        !           312: 	    my ($name,$url,$ext)=split(/\:/,$resources[$order[$i]]);
        !           313: 	    unless ($url) {
        !           314: # Take out empty resource
        !           315: 		for (my $j=$i+1;$j<=$#order;$j++) {
        !           316: 		    $order[$j-1]=$order[$j];
        !           317: 		}
        !           318: 		$#order--;
        !           319: 		$stillchange=1;
        !           320: 		last;
        !           321: 	    }
        !           322: 	}
        !           323:     }
        !           324: # Put in a start resource
        !           325:     my ($name,$url,$ext)=split(/\:/,$resources[$order[0]]);
        !           326:     $resources[$order[0]]=$name.':'.$url.':'.$ext.':start:res';
        !           327: # Make sure this has at least start and finish
        !           328:     if ($#order==0) {
        !           329: 	$resources[&getresidx()]='::false';
        !           330: 	$order[1]=$#resources;
        !           331:     }
        !           332: # Make the last one a finish resource
        !           333:     ($name,$url,$ext)=split(/\:/,$resources[$order[$#order]]);
        !           334:     $resources[$order[$#order]]=$name.':'.$url.':'.$ext.':finish:res';
        !           335: }
        !           336: 
        !           337: # ------------------------------------------------------------------- Store map
        !           338: 
        !           339: sub storemap {
        !           340:     my $realfn=shift;
        !           341:     my $fn=$realfn;
        !           342: # unless this is forced to work from the original file, use a temporary file
        !           343: # instead
        !           344:     unless (shift) {
        !           345: 	$fn=$realfn.'.tmp';
        !           346: 	unless (-e $fn) {
        !           347: 	    copy($realfn,$fn);
        !           348: 	}
        !           349:     }
        !           350: # store data either into tmp or real file
        !           351:     &startfinish();
        !           352:     my $output='graphdef<:>no';
        !           353:     my $k=1;
        !           354:     for (my $i=0; $i<=$#order; $i++) {
        !           355:         if (defined($resources[$order[$i]])) {
        !           356: 	    $output.='<&>objcont<:>'.$order[$i].'<:>'.$resources[$order[$i]];
        !           357:         }
        !           358: 	if (defined($resparms[$order[$i]])) {
        !           359: 	    foreach (split('&&&',$resparms[$order[$i]])) {
        !           360: 		if ($_) {
        !           361: 		    $output.='<&>objparms<:>'.$order[$i].'<:>'.$_;
        !           362: 		}
        !           363: 	    }
        !           364: 	}
        !           365:         if (defined($order[$i+1])) {
        !           366: 	    if (defined($resources[$order[$i+1]])) {
        !           367: 		$output.='<&>objlinks<:>'.$k.'<:>'.
        !           368: 		    $order[$i].':'.$order[$i+1].':0';
        !           369: 		$k++;
        !           370:             }
        !           371:         }
        !           372:     }
        !           373:     for (my $i=0; $i<=$#zombies; $i++) {
        !           374:         if (defined($zombies[$i])) {
        !           375: 	    $output.='<&>objcont<:>'.$i.'<:>'.$zombies[$i];
        !           376:         }
        !           377:     }
        !           378:     $output=~s/http\&colon\;\/\///g;
        !           379:     $env{'form.output'}=$output;
        !           380:     return &loadmap($fn,&savemap($fn,''));
        !           381: }
        !           382: 
        !           383: # ------------------------------------------ Store and get parameters in global
        !           384: 
        !           385: sub storeparameter {
        !           386:     my ($to,$name,$value,$ptype)=@_;
        !           387:     my $newentry='';
        !           388:     my $nametype='';
        !           389:     foreach (split('&&&',$resparms[$to])) {
        !           390: 	my ($thistype,$thisname,$thisvalue)=split('___',$_);
        !           391: 	if ($thisname) {
        !           392: 	    unless ($thisname eq $name) {
        !           393: 		$newentry.=$_.'&&&';
        !           394: 	    } else {
        !           395: 		$nametype=$thistype;
        !           396: 	    }
        !           397: 	}
        !           398:     }
        !           399:     unless ($ptype) { $ptype=$nametype; }
        !           400:     unless ($ptype) { $ptype='string'; }
        !           401:     $newentry.=$ptype.'___'.$name.'___'.$value;
        !           402:     $resparms[$to]=$newentry;
        !           403: }
        !           404: 
        !           405: sub delparameter {
        !           406:     my ($to,$name)=@_;
        !           407:     my $newentry='';
        !           408:     my $nametype='';
        !           409:     foreach (split('&&&',$resparms[$to])) {
        !           410: 	my ($thistype,$thisname,$thisvalue)=split('___',$_);
        !           411: 	if ($thisname) {
        !           412: 	    unless ($thisname eq $name) {
        !           413: 		$newentry.=$_.'&&&';
        !           414: 	    }
        !           415: 	}
        !           416:     }
        !           417:     $resparms[$to]=$newentry;
        !           418: }
        !           419: 
        !           420: sub getparameter {
        !           421:     my ($to,$name)=@_;
        !           422:     my $value=undef;
        !           423:     my $ptype=undef;
        !           424:     foreach (split('&&&',$resparms[$to])) {
        !           425: 	my ($thistype,$thisname,$thisvalue)=split('___',$_);
        !           426: 	if ($thisname eq $name) {
        !           427: 	    $value=$thisvalue;
        !           428: 	    $ptype=$thistype;
        !           429: 	}
        !           430:     }
        !           431:     return ($value,$ptype);
        !           432: }
        !           433: 
        !           434: # ------------------------------------------------------------- From RAT to XML
        !           435: 
        !           436: sub qtescape {
        !           437:     my $str=shift;
        !           438:     $str=~s/\&colon;/\:/g;
        !           439:     $str=~s/\&\#58\;/\:/g;
        !           440:     $str=~s/\&\#39\;/\'/g;
        !           441:     $str=~s/\&\#44\;/\,/g;
        !           442:     $str=~s/\"/\&\#34\;/g;
        !           443:     return $str;
        !           444: }
        !           445: 
        !           446: # ------------------------------------------------------------- From XML to RAT
        !           447: 
        !           448: sub qtunescape {
        !           449:     my $str=shift;
        !           450:     $str=~s/\:/\&colon\;/g;
        !           451:     $str=~s/\'/\&\#39\;/g;
        !           452:     $str=~s/\,/\&\#44\;/g;
        !           453:     $str=~s/\"/\&\#34\;/g;
        !           454:     return $str;
        !           455: }
        !           456: 
        !           457: # --------------------------------------------------------- Loads map from disk
        !           458: 
        !           459: sub loadmap {
        !           460:     my ($fn,$errtext,$infotext)=@_;
        !           461:     if ($errtext) { return('',$errtext); }
        !           462:     my $outstr='';
        !           463:     my @obj=();
        !           464:     my @links=();
        !           465:     my $instr='';
        !           466:     if ($fn=~/^\/*uploaded\//) {
        !           467:         $instr=&Apache::lonnet::getfile($fn);
        !           468:     } elsif (-e $fn) {
        !           469:         my @content=();
        !           470:         {
        !           471: 	    open(my $fh,"<$fn");
        !           472:             @content=<$fh>;
        !           473:         }
        !           474:         $instr=join('',@content);
        !           475:     }
        !           476:     if ($instr eq -2) {
        !           477:         $errtext.='Map not loaded: An error occured while trying to load the map.';
        !           478:     } elsif ($instr) {
        !           479:         my $parser = HTML::TokeParser->new(\$instr);
        !           480:         my $token;
        !           481:         my $graphmode=0;
        !           482: 
        !           483:         $fn=~/\.(\w+)$/;
        !           484:         $outstr="mode<:>$1";
        !           485: 
        !           486:         while ($token = $parser->get_token) {
        !           487: 	    if ($token->[0] eq 'S') {
        !           488:                 if ($token->[1] eq 'map') {
        !           489: 		    $graphmode=($token->[2]->{'mode'} eq 'rat/graphical');
        !           490:                 } elsif ($token->[1] eq 'resource') {
        !           491: # -------------------------------------------------------------------- Resource
        !           492:                     $outstr.='<&>objcont';
        !           493:                     if (defined($token->[2]->{'id'})) {
        !           494: 			$outstr.='<:>'.$token->[2]->{'id'};
        !           495:                         if ($obj[$token->[2]->{'id'}]==1) {
        !           496: 			    $errtext.='Error: multiple use of ID '.
        !           497: 				$token->[2]->{'id'}.'. ';
        !           498:                         }
        !           499:                         $obj[$token->[2]->{'id'}]=1; 
        !           500:                     } else {
        !           501:                         my $i=1;
        !           502:                         while (($i<=$#obj) && ($obj[$i]!=0)) { $i++; }
        !           503:                         $outstr.='<:>'.$i;
        !           504:                         $obj[$i]=1;
        !           505:                     }
        !           506:                     $outstr.='<:>';
        !           507:                     $outstr.=qtunescape($token->[2]->{'title'}).":";
        !           508:                     $outstr.=qtunescape($token->[2]->{'src'}).":";
        !           509:                     if ($token->[2]->{'external'} eq 'true') {
        !           510:                         $outstr.='true:';
        !           511:                     } else {
        !           512:                         $outstr.='false:';
        !           513:                     }
        !           514:                     if (defined($token->[2]->{'type'})) {
        !           515: 			$outstr.=$token->[2]->{'type'}.':';
        !           516:                     }  else {
        !           517:                         $outstr.='normal:';
        !           518:                     }
        !           519: 		    if ($token->[2]->{'type'} ne 'zombie') {
        !           520: 			$outstr.='res';
        !           521: 		    } else {
        !           522:                         $outstr.='zombie';
        !           523: 		    }
        !           524:                 } elsif ($token->[1] eq 'condition') {
        !           525: # ------------------------------------------------------------------- Condition
        !           526:                     $outstr.='<&>objcont';
        !           527:                     if (defined($token->[2]->{'id'})) {
        !           528: 			$outstr.='<:>'.$token->[2]->{'id'};
        !           529:                         if ($obj[$token->[2]->{'id'}]==1) {
        !           530: 			    $errtext.='Error: multiple use of ID '.
        !           531: 				$token->[2]->{'id'}.'. ';
        !           532:                         }
        !           533:                         $obj[$token->[2]->{'id'}]=1; 
        !           534:                     } else {
        !           535:                         my $i=1;
        !           536:                         while (($i<=$#obj) && ($obj[$i]!=0)) { $i++; }
        !           537:                         $outstr.='<:>'.$i;
        !           538:                         $obj[$i]=1;
        !           539:                     }
        !           540:                     $outstr.='<:>';
        !           541:                     $outstr.=qtunescape($token->[2]->{'value'}).':';
        !           542:                     if (defined($token->[2]->{'type'})) {
        !           543: 			$outstr.=$token->[2]->{'type'}.':';
        !           544:                     } else {
        !           545:                         $outstr.='normal:';
        !           546:                     }
        !           547:                     $outstr.='cond';
        !           548:                 } elsif ($token->[1] eq 'link') {
        !           549: # ----------------------------------------------------------------------- Links
        !           550:                     $outstr.='<&>objlinks';
        !           551: 		    
        !           552: 		    if (defined($token->[2]->{'index'})) {
        !           553: 			if ($links[$token->[2]->{'index'}]) {
        !           554: 			    $errtext.='Error: multiple use of link index '.
        !           555: 				$token->[2]->{'index'}.'. ';
        !           556: 			}
        !           557: 			$outstr.='<:>'.$token->[2]->{'index'};
        !           558: 			$links[$token->[2]->{'index'}]=1;
        !           559: 		    } else {
        !           560: 			my $i=1;
        !           561: 			while (($i<=$#links) && ($links[$i]==1)) { $i++; }
        !           562: 			$outstr.='<:>'.$i;
        !           563: 			$links[$i]=1;
        !           564: 		    }
        !           565: 		    
        !           566:                     $outstr.='<:>'.$token->[2]->{'from'}.
        !           567: 			':'.$token->[2]->{'to'};
        !           568:                     if (defined($token->[2]->{'condition'})) {
        !           569: 			$outstr.=':'.$token->[2]->{'condition'};
        !           570:                     } else {
        !           571:  			$outstr.=':0';
        !           572:                     }
        !           573: # ------------------------------------------------------------------- Parameter
        !           574:                 } elsif ($token->[1] eq 'param') {
        !           575:                     $outstr.='<&>objparms<:>'.$token->[2]->{'to'}.'<:>'.
        !           576: 			$token->[2]->{'type'}.'___'.$token->[2]->{'name'}.
        !           577: 			'___'.$token->[2]->{'value'};
        !           578:                 } elsif ($graphmode) {
        !           579: # --------------------------------------------- All other tags (graphical only)
        !           580:                     $outstr.='<&>'.$token->[1];
        !           581:                     if (defined($token->[2]->{'index'})) {
        !           582: 			$outstr.='<:>'.$token->[2]->{'index'};
        !           583:                         if ($token->[1] eq 'obj') {
        !           584: 			    $obj[$token->[2]->{'index'}]=2;
        !           585:                         }
        !           586:                     }
        !           587:                     $outstr.='<:>'.$token->[2]->{'value'};
        !           588:                 }
        !           589:             }
        !           590:         }
        !           591: 
        !           592:     } else {
        !           593:         $errtext.='Map not loaded: The file does not exist. ';
        !           594:     }
        !           595:     return($outstr,$errtext,$infotext);
        !           596: }
        !           597: 
        !           598: 
        !           599: # ----------------------------------------------------------- Saves map to disk
        !           600: 
        !           601: sub savemap {
        !           602:     my ($fn,$errtext)=@_;
        !           603:     my $infotext='';
        !           604:     my %alltypes;
        !           605:     my %allvalues;
        !           606:     if (($fn=~/\.sequence(\.tmp)*$/) ||
        !           607:         ($fn=~/\.page(\.tmp)*$/)) {
        !           608: 	
        !           609: # ------------------------------------------------------------- Deal with input
        !           610:         my @tags=split(/<&>/,$env{'form.output'});
        !           611:         my $outstr='';
        !           612:         my $graphdef=0;
        !           613:         if ($tags[0] eq 'graphdef<:>yes') {
        !           614: 	    $outstr='<map mode="rat/graphical">'."\n";
        !           615:             $graphdef=1;
        !           616:         } else {
        !           617:             $outstr="<map>\n";
        !           618:         }
        !           619:         foreach (@tags) {
        !           620: 	    my @parts=split(/<:>/,$_);
        !           621: 	    if ($parts[0] eq 'objcont') {
        !           622: 		my @comp=split(/:/,$parts[$#parts]);
        !           623: # --------------------------------------------------------------- Logical input
        !           624: 		if (($comp[$#comp] eq 'res') || ($comp[$#comp] eq 'zombie')) {
        !           625: 		    $comp[0]=qtescape($comp[0]);
        !           626: 		    $comp[1]=qtescape($comp[1]);
        !           627: 		    if ($comp[2] eq 'true') {
        !           628: 			if ($comp[1]!~/^http\:\/\//) {
        !           629: 			    $comp[1]='http://'.$comp[1];
        !           630: 			}
        !           631: 			$comp[1].='" external="true';
        !           632: 		    } else {
        !           633: 			if ($comp[1]=~/^http\:\/\//) {
        !           634: 			    $comp[1]=~s/^http\:\/\/[^\/]*\//\//;
        !           635: 			}
        !           636: 		    }
        !           637: 		    $outstr.='<resource id="'.$parts[1].'" src="'
        !           638: 			.$comp[1].'"';
        !           639: 		    
        !           640: 		    if (($comp[3] ne '') && ($comp[3] ne 'normal')) {
        !           641: 			$outstr.=' type="'.$comp[3].'"';
        !           642: 		    }
        !           643: 		    if ($comp[0] ne '') {
        !           644: 			$outstr.=' title="'.$comp[0].'"';
        !           645: 		    }
        !           646: 		    $outstr.=" />\n";
        !           647: 		} elsif ($comp[$#comp] eq 'cond') {
        !           648: 		    $outstr.='<condition id="'.$parts[1].'"';
        !           649: 		    if (($comp[1] ne '') && ($comp[1] ne 'normal')) {
        !           650: 			$outstr.=' type="'.$comp[1].'"';
        !           651: 		    }
        !           652: 		    $outstr.=' value="'.qtescape($comp[0]).'"';
        !           653: 		    $outstr.=" />\n";
        !           654: 		}
        !           655: 	    } elsif ($parts[0] eq 'objlinks') {
        !           656: 		my @comp=split(/:/,$parts[$#parts]);
        !           657: 		$outstr.='<link';
        !           658: 		$outstr.=' from="'.$comp[0].'"';
        !           659: 		$outstr.=' to="'.$comp[1].'"';
        !           660: 		if (($comp[2] ne '') && ($comp[2]!=0)) {
        !           661: 		    $outstr.=' condition="'.$comp[2].'"';
        !           662: 		}
        !           663: 		$outstr.=' index="'.$parts[1].'"';
        !           664: 		$outstr.=" />\n";
        !           665: 	    } elsif ($parts[0] eq 'objparms') {
        !           666: 		undef %alltypes;
        !           667: 		undef %allvalues;
        !           668: 		foreach (split(/:/,$parts[$#parts])) {
        !           669: 		    my ($type,$name,$value)=split(/\_\_\_/,$_);
        !           670: 		    $alltypes{$name}=$type;
        !           671: 		    $allvalues{$name}=$value;
        !           672: 		}
        !           673: 		foreach (keys %allvalues) {
        !           674: 		    if ($allvalues{$_} ne '') {
        !           675: 			$outstr.='<param to="'.$parts[1].'" type="'
        !           676: 			    .$alltypes{$_}.'" name="'.$_
        !           677: 			    .'" value="'.$allvalues{$_}.'" />'
        !           678: 			    ."\n";
        !           679: 		    }
        !           680: 		}
        !           681: 	    } elsif (($parts[0] ne '') && ($graphdef)) {
        !           682: # ------------------------------------------------------------- Graphical input
        !           683: 		$outstr.='<'.$parts[0];
        !           684: 		if ($#parts==2) {
        !           685: 		    $outstr.=' index="'.$parts[1].'"';
        !           686: 		}
        !           687: 		$outstr.=' value="'.qtescape($parts[$#parts]).'" />'."\n";
        !           688: 	    }
        !           689:         }
        !           690:         $outstr.="</map>\n";
        !           691: 	if ($fn=~/^\/*uploaded\/(\w+)\/(\w+)\/(.*)$/) {
        !           692: 	    $env{'form.output'}=$outstr;
        !           693:             my $result=&Apache::lonnet::finishuserfileupload($2,$1,
        !           694: 							     'output',$3);
        !           695: 	    if ($result != m|^/uploaded/|) {
        !           696: 		$errtext.='Map not saved: A network error occured when trying to save the map. ';
        !           697: 	    }
        !           698:         } else {
        !           699: 	    if (open(my $fh,">$fn")) {
        !           700: 		print $fh $outstr;
        !           701: 		$infotext.="Map saved as $fn. ";
        !           702: 	    } else {
        !           703: 		$errtext.='Could not write file '.$fn.'.  Map not saved. ';
        !           704: 	    }
        !           705:         }
        !           706:     } else {
        !           707: # -------------------------------------------- Cannot write to that file, error
        !           708:         $errtext.='Map not saved: The specified path does not exist. ';
        !           709:     }
        !           710:     return ($errtext,$infotext);
        !           711: }
        !           712: 
        !           713: 1;
        !           714: __END__

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>