File:  [LON-CAPA] / rat / map.pm
Revision 1.15: download - view: text, annotated - select for diffs
Sat Jun 14 19:05:00 2014 UTC (8 years, 2 months ago) by raeburn
Branches: MAIN
CVS tags: version_2_12_X, version_2_11_X, version_2_11_4_uiuc, version_2_11_4_msu, version_2_11_4, version_2_11_3_uiuc, version_2_11_3_msu, version_2_11_3, version_2_11_2_uiuc, version_2_11_2_msu, version_2_11_2_educog, version_2_11_2, version_2_11_1, version_2_11_0, HEAD
- Using "multiple" radio and checking "Remove All" in Course Editor results
  in a map containing only zombies, so map::startfinish() needs to add both
  start and finish.

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

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