Annotation of rat/map.pm, revision 1.16
1.1 albertel 1: # The LearningOnline Network with CAPA
2: # routines for modyfing .sequence and .page files
3: #
1.16 ! raeburn 4: # $Id: map.pm,v 1.15 2014/06/14 19:05:00 raeburn Exp $
1.1 albertel 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;
1.10 albertel 30: use strict;
1.1 albertel 31: use HTML::TokeParser;
1.5 albertel 32: use HTML::Entities();
1.1 albertel 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 {
1.9 albertel 148: my ($fn,$unsorted)=@_;
1.1 albertel 149:
150: my @links;
151: my @theseres;
152:
153: my ($outtext,$errtext)=&loadmap($fn,'');
154: if ($errtext) { return @theseres }
155:
156: # -------------------------------------------------------------------- Read map
1.10 albertel 157: my ($start,$finish);
1.1 albertel 158: foreach (split(/\<\&\>/,$outtext)) {
159: my ($command,$number,$content)=split(/\<\:\>/,$_);
160: if ($command eq 'objcont') {
1.10 albertel 161: my ($title,$src,$ext,$type)=split(/\:/,$content);
162: if ($type ne 'zombie' && $ext ne 'cond') {
1.1 albertel 163: $theseres[$number]=$content;
164: }
1.10 albertel 165: if ($type eq 'start') {
166: $start = $number;
167: }
168: if ($type eq 'finish') {
169: $finish = $number;
170: }
1.1 albertel 171: }
172: if ($command eq 'objlinks') {
173: $links[$number]=$content;
174: }
175: }
1.9 albertel 176: if ($unsorted) {
1.10 albertel 177: return @theseres;
1.9 albertel 178: }
1.1 albertel 179:
1.10 albertel 180: # ---------------------------- attempt to flatten the map into a 'sorted' order
1.1 albertel 181:
1.10 albertel 182: my %path_length = ($start => 0);
183: my @todo = @links;
1.1 albertel 184:
1.10 albertel 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);
1.1 albertel 203: }
1.10 albertel 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]);
1.1 albertel 211: }
212: }
1.10 albertel 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]);
1.1 albertel 216: return @outres;
217: }
218:
219: # ------------------------------------- Revive zombie idx or get unused number
220:
221: sub getresidx {
1.7 albertel 222: my ($url,$residx)= @_;
1.1 albertel 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) {
1.7 albertel 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: }
1.1 albertel 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($_)) {
1.8 albertel 261: my ($name,$url,$residx)=split(/\=/,$_);
1.1 albertel 262: $name=&unescape($name);
263: $url=&unescape($url);
264: if ($url) {
1.8 albertel 265: my $idx=&getresidx($url,$residx);
1.1 albertel 266: $insertorder[$#insertorder+1]=$idx;
267: my $ext='false';
1.12 raeburn 268: if ($url=~/^https?\:\/\//) { $ext='true'; }
1.1 albertel 269: $url=~s/\:/\:/g;
270: $name=~s/\:/\:/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[$_]);
1.12 raeburn 286: if ($url=~/https?\&colon\:\/\//) { $ext='true'; }
1.1 albertel 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: }
1.15 raeburn 306: # Make sure this has at least start and finish
307: if ($#order==-1) {
308: $resources[&getresidx()]='::false';
309: $order[0]=$#resources;
310: }
1.1 albertel 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 {
1.14 raeburn 326: my ($realfn,$useorig,$dotimeupdate) = @_;
1.1 albertel 327: my $fn=$realfn;
328: # unless this is forced to work from the original file, use a temporary file
329: # instead
1.14 raeburn 330: unless ($useorig) {
1.1 albertel 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: }
1.13 raeburn 364: $output=~s/http\&colon\;\/\///g;
1.1 albertel 365: $env{'form.output'}=$output;
1.14 raeburn 366: return &loadmap($fn,&savemap($fn,'',$dotimeupdate));
1.1 albertel 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/\:/\:/g;
425: $str=~s/\&\#58\;/\:/g;
426: $str=~s/\&\#39\;/\'/g;
427: $str=~s/\&\#44\;/\,/g;
1.6 albertel 428: $str=~s/\&\#34\;/\"/g;
1.1 albertel 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) {
1.11 bisitz 463: $errtext.='Map not loaded: An error occurred while trying to load the map.';
1.2 raeburn 464: } elsif ($instr eq '-1') {
1.4 albertel 465: # Map doesn't exist
1.1 albertel 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 {
1.14 raeburn 590: my ($fn,$errtext,$dotimeupdate)=@_;
1.1 albertel 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]);
1.6 albertel 614: $comp[0] = &HTML::Entities::encode($comp[0],'&<>"');
615:
1.1 albertel 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 {
1.13 raeburn 623: if ($comp[1]=~/^http\:\/\//) {
624: $comp[1]=~s/^http\:\/\/[^\/]*\//\//;
1.1 albertel 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 '') {
1.6 albertel 634: $outstr.=' title="'.$comp[0].'"';
1.1 albertel 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";
1.16 ! raeburn 681: my ($cdom,$cnum,$mapname);
1.3 albertel 682: if ($fn=~m{^/*uploaded/($LONCAPA::domain_re)/($LONCAPA::courseid_re)/(.*)$}) {
1.16 ! raeburn 683: ($cdom,$cnum,$mapname) = ($1,$2,$3);
1.1 albertel 684: $env{'form.output'}=$outstr;
1.16 ! raeburn 685: my $result=&Apache::lonnet::finishuserfileupload($cnum,$cdom,
! 686: 'output',$mapname);
1.1 albertel 687: if ($result != m|^/uploaded/|) {
1.11 bisitz 688: $errtext.='Map not saved: A network error occurred when trying to save the map. ';
1.1 albertel 689: }
690: } else {
691: if (open(my $fh,">$fn")) {
692: print $fh $outstr;
693: $infotext.="Map saved as $fn. ";
694: } else {
695: $errtext.='Could not write file '.$fn.'. Map not saved. ';
696: }
697: }
1.14 raeburn 698: if ($dotimeupdate) {
699: unless ($errtext) {
700: if ($env{'request.course.id'}) {
1.16 ! raeburn 701: if (($cdom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) &&
! 702: ($cnum eq $env{'course.'.$env{'request.course.id'}.'.num'}) &&
! 703: ($mapname =~ /^supplemental(|_\d+)\.sequence$/)) {
! 704: &Apache::lonnet::update_supp_caches($cdom,$cnum);
! 705: } else {
! 706: my $now = time;
! 707: &Apache::lonnet::put('environment',{'internal.contentchange' => $now},
! 708: $env{'course.'.$env{'request.course.id'}.'.domain'},
! 709: $env{'course.'.$env{'request.course.id'}.'.num'});
! 710: &Apache::lonnet::appenv(
! 711: {'course.'.$env{'request.course.id'}.'.internal.contentchange' => $now});
! 712: &Apache::lonnet::do_cache_new('crschange',$env{'request.course.id'},$now,600);
! 713: }
1.14 raeburn 714: }
715: }
716: }
1.1 albertel 717: } else {
718: # -------------------------------------------- Cannot write to that file, error
719: $errtext.='Map not saved: The specified path does not exist. ';
720: }
721: return ($errtext,$infotext);
722: }
723:
724: 1;
725: __END__
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to map.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / rat