File:  [LON-CAPA] / rat / map.pm
Revision 1.2: download - view: text, annotated - select for diffs
Mon Dec 4 14:59:55 2006 UTC (15 years, 8 months ago) by raeburn
Branches: MAIN
CVS tags: HEAD
Checking for existence of allgroups_folder.sequence uses map.pm to check the file system instead of using navmap object to check current user's session.

Locking added while allgroups_folder.sequence is being added, to avoid contention between two CCs adding the first group to a course at the same time.

rat::loadmap() now checks for a return value of -1, as lonnet::getfile() returns -1 when the file is missing.  Not sure when the existing branch (checks for -2) is triggered.

    1: # The LearningOnline Network with CAPA
    2: # routines for modyfing .sequence and .page files
    3: #
    4: # $Id: map.pm,v 1.2 2006/12/04 14:59:55 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: 
   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 eq '-1') {
  479:         $errtext.=&mt('Map not loaded: The file [_1] does not exist.',$fn);
  480:     } elsif ($instr) {
  481:         my $parser = HTML::TokeParser->new(\$instr);
  482:         my $token;
  483:         my $graphmode=0;
  484: 
  485:         $fn=~/\.(\w+)$/;
  486:         $outstr="mode<:>$1";
  487: 
  488:         while ($token = $parser->get_token) {
  489: 	    if ($token->[0] eq 'S') {
  490:                 if ($token->[1] eq 'map') {
  491: 		    $graphmode=($token->[2]->{'mode'} eq 'rat/graphical');
  492:                 } elsif ($token->[1] eq 'resource') {
  493: # -------------------------------------------------------------------- Resource
  494:                     $outstr.='<&>objcont';
  495:                     if (defined($token->[2]->{'id'})) {
  496: 			$outstr.='<:>'.$token->[2]->{'id'};
  497:                         if ($obj[$token->[2]->{'id'}]==1) {
  498: 			    $errtext.='Error: multiple use of ID '.
  499: 				$token->[2]->{'id'}.'. ';
  500:                         }
  501:                         $obj[$token->[2]->{'id'}]=1; 
  502:                     } else {
  503:                         my $i=1;
  504:                         while (($i<=$#obj) && ($obj[$i]!=0)) { $i++; }
  505:                         $outstr.='<:>'.$i;
  506:                         $obj[$i]=1;
  507:                     }
  508:                     $outstr.='<:>';
  509:                     $outstr.=qtunescape($token->[2]->{'title'}).":";
  510:                     $outstr.=qtunescape($token->[2]->{'src'}).":";
  511:                     if ($token->[2]->{'external'} eq 'true') {
  512:                         $outstr.='true:';
  513:                     } else {
  514:                         $outstr.='false:';
  515:                     }
  516:                     if (defined($token->[2]->{'type'})) {
  517: 			$outstr.=$token->[2]->{'type'}.':';
  518:                     }  else {
  519:                         $outstr.='normal:';
  520:                     }
  521: 		    if ($token->[2]->{'type'} ne 'zombie') {
  522: 			$outstr.='res';
  523: 		    } else {
  524:                         $outstr.='zombie';
  525: 		    }
  526:                 } elsif ($token->[1] eq 'condition') {
  527: # ------------------------------------------------------------------- Condition
  528:                     $outstr.='<&>objcont';
  529:                     if (defined($token->[2]->{'id'})) {
  530: 			$outstr.='<:>'.$token->[2]->{'id'};
  531:                         if ($obj[$token->[2]->{'id'}]==1) {
  532: 			    $errtext.='Error: multiple use of ID '.
  533: 				$token->[2]->{'id'}.'. ';
  534:                         }
  535:                         $obj[$token->[2]->{'id'}]=1; 
  536:                     } else {
  537:                         my $i=1;
  538:                         while (($i<=$#obj) && ($obj[$i]!=0)) { $i++; }
  539:                         $outstr.='<:>'.$i;
  540:                         $obj[$i]=1;
  541:                     }
  542:                     $outstr.='<:>';
  543:                     $outstr.=qtunescape($token->[2]->{'value'}).':';
  544:                     if (defined($token->[2]->{'type'})) {
  545: 			$outstr.=$token->[2]->{'type'}.':';
  546:                     } else {
  547:                         $outstr.='normal:';
  548:                     }
  549:                     $outstr.='cond';
  550:                 } elsif ($token->[1] eq 'link') {
  551: # ----------------------------------------------------------------------- Links
  552:                     $outstr.='<&>objlinks';
  553: 		    
  554: 		    if (defined($token->[2]->{'index'})) {
  555: 			if ($links[$token->[2]->{'index'}]) {
  556: 			    $errtext.='Error: multiple use of link index '.
  557: 				$token->[2]->{'index'}.'. ';
  558: 			}
  559: 			$outstr.='<:>'.$token->[2]->{'index'};
  560: 			$links[$token->[2]->{'index'}]=1;
  561: 		    } else {
  562: 			my $i=1;
  563: 			while (($i<=$#links) && ($links[$i]==1)) { $i++; }
  564: 			$outstr.='<:>'.$i;
  565: 			$links[$i]=1;
  566: 		    }
  567: 		    
  568:                     $outstr.='<:>'.$token->[2]->{'from'}.
  569: 			':'.$token->[2]->{'to'};
  570:                     if (defined($token->[2]->{'condition'})) {
  571: 			$outstr.=':'.$token->[2]->{'condition'};
  572:                     } else {
  573:  			$outstr.=':0';
  574:                     }
  575: # ------------------------------------------------------------------- Parameter
  576:                 } elsif ($token->[1] eq 'param') {
  577:                     $outstr.='<&>objparms<:>'.$token->[2]->{'to'}.'<:>'.
  578: 			$token->[2]->{'type'}.'___'.$token->[2]->{'name'}.
  579: 			'___'.$token->[2]->{'value'};
  580:                 } elsif ($graphmode) {
  581: # --------------------------------------------- All other tags (graphical only)
  582:                     $outstr.='<&>'.$token->[1];
  583:                     if (defined($token->[2]->{'index'})) {
  584: 			$outstr.='<:>'.$token->[2]->{'index'};
  585:                         if ($token->[1] eq 'obj') {
  586: 			    $obj[$token->[2]->{'index'}]=2;
  587:                         }
  588:                     }
  589:                     $outstr.='<:>'.$token->[2]->{'value'};
  590:                 }
  591:             }
  592:         }
  593: 
  594:     } else {
  595:         $errtext.='Map not loaded: The file does not exist. ';
  596:     }
  597:     return($outstr,$errtext,$infotext);
  598: }
  599: 
  600: 
  601: # ----------------------------------------------------------- Saves map to disk
  602: 
  603: sub savemap {
  604:     my ($fn,$errtext)=@_;
  605:     my $infotext='';
  606:     my %alltypes;
  607:     my %allvalues;
  608:     if (($fn=~/\.sequence(\.tmp)*$/) ||
  609:         ($fn=~/\.page(\.tmp)*$/)) {
  610: 	
  611: # ------------------------------------------------------------- Deal with input
  612:         my @tags=split(/<&>/,$env{'form.output'});
  613:         my $outstr='';
  614:         my $graphdef=0;
  615:         if ($tags[0] eq 'graphdef<:>yes') {
  616: 	    $outstr='<map mode="rat/graphical">'."\n";
  617:             $graphdef=1;
  618:         } else {
  619:             $outstr="<map>\n";
  620:         }
  621:         foreach (@tags) {
  622: 	    my @parts=split(/<:>/,$_);
  623: 	    if ($parts[0] eq 'objcont') {
  624: 		my @comp=split(/:/,$parts[$#parts]);
  625: # --------------------------------------------------------------- Logical input
  626: 		if (($comp[$#comp] eq 'res') || ($comp[$#comp] eq 'zombie')) {
  627: 		    $comp[0]=qtescape($comp[0]);
  628: 		    $comp[1]=qtescape($comp[1]);
  629: 		    if ($comp[2] eq 'true') {
  630: 			if ($comp[1]!~/^http\:\/\//) {
  631: 			    $comp[1]='http://'.$comp[1];
  632: 			}
  633: 			$comp[1].='" external="true';
  634: 		    } else {
  635: 			if ($comp[1]=~/^http\:\/\//) {
  636: 			    $comp[1]=~s/^http\:\/\/[^\/]*\//\//;
  637: 			}
  638: 		    }
  639: 		    $outstr.='<resource id="'.$parts[1].'" src="'
  640: 			.$comp[1].'"';
  641: 		    
  642: 		    if (($comp[3] ne '') && ($comp[3] ne 'normal')) {
  643: 			$outstr.=' type="'.$comp[3].'"';
  644: 		    }
  645: 		    if ($comp[0] ne '') {
  646: 			$outstr.=' title="'.$comp[0].'"';
  647: 		    }
  648: 		    $outstr.=" />\n";
  649: 		} elsif ($comp[$#comp] eq 'cond') {
  650: 		    $outstr.='<condition id="'.$parts[1].'"';
  651: 		    if (($comp[1] ne '') && ($comp[1] ne 'normal')) {
  652: 			$outstr.=' type="'.$comp[1].'"';
  653: 		    }
  654: 		    $outstr.=' value="'.qtescape($comp[0]).'"';
  655: 		    $outstr.=" />\n";
  656: 		}
  657: 	    } elsif ($parts[0] eq 'objlinks') {
  658: 		my @comp=split(/:/,$parts[$#parts]);
  659: 		$outstr.='<link';
  660: 		$outstr.=' from="'.$comp[0].'"';
  661: 		$outstr.=' to="'.$comp[1].'"';
  662: 		if (($comp[2] ne '') && ($comp[2]!=0)) {
  663: 		    $outstr.=' condition="'.$comp[2].'"';
  664: 		}
  665: 		$outstr.=' index="'.$parts[1].'"';
  666: 		$outstr.=" />\n";
  667: 	    } elsif ($parts[0] eq 'objparms') {
  668: 		undef %alltypes;
  669: 		undef %allvalues;
  670: 		foreach (split(/:/,$parts[$#parts])) {
  671: 		    my ($type,$name,$value)=split(/\_\_\_/,$_);
  672: 		    $alltypes{$name}=$type;
  673: 		    $allvalues{$name}=$value;
  674: 		}
  675: 		foreach (keys %allvalues) {
  676: 		    if ($allvalues{$_} ne '') {
  677: 			$outstr.='<param to="'.$parts[1].'" type="'
  678: 			    .$alltypes{$_}.'" name="'.$_
  679: 			    .'" value="'.$allvalues{$_}.'" />'
  680: 			    ."\n";
  681: 		    }
  682: 		}
  683: 	    } elsif (($parts[0] ne '') && ($graphdef)) {
  684: # ------------------------------------------------------------- Graphical input
  685: 		$outstr.='<'.$parts[0];
  686: 		if ($#parts==2) {
  687: 		    $outstr.=' index="'.$parts[1].'"';
  688: 		}
  689: 		$outstr.=' value="'.qtescape($parts[$#parts]).'" />'."\n";
  690: 	    }
  691:         }
  692:         $outstr.="</map>\n";
  693: 	if ($fn=~/^\/*uploaded\/(\w+)\/(\w+)\/(.*)$/) {
  694: 	    $env{'form.output'}=$outstr;
  695:             my $result=&Apache::lonnet::finishuserfileupload($2,$1,
  696: 							     'output',$3);
  697: 	    if ($result != m|^/uploaded/|) {
  698: 		$errtext.='Map not saved: A network error occured when trying to save the map. ';
  699: 	    }
  700:         } else {
  701: 	    if (open(my $fh,">$fn")) {
  702: 		print $fh $outstr;
  703: 		$infotext.="Map saved as $fn. ";
  704: 	    } else {
  705: 		$errtext.='Could not write file '.$fn.'.  Map not saved. ';
  706: 	    }
  707:         }
  708:     } else {
  709: # -------------------------------------------- Cannot write to that file, error
  710:         $errtext.='Map not saved: The specified path does not exist. ';
  711:     }
  712:     return ($errtext,$infotext);
  713: }
  714: 
  715: 1;
  716: __END__

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