Annotation of loncom/imspackages/imsprocessor.pm, revision 1.53
1.45 www 1: # The LearningOnline Network with CAPA
2: # Processor for IMS Packages
3: #
1.52 raeburn 4: # $Id: imsprocessor.pm,v 1.51 2012/12/18 18:54:11 raeburn Exp $
1.45 www 5: #
1.10 raeburn 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:
1.1 raeburn 29: package Apache::imsprocessor;
30:
31: use Apache::lonnet;
1.21 www 32: use Apache::loncleanup;
1.42 raeburn 33: use Apache::lonlocal;
1.20 raeburn 34: use LWP::UserAgent;
35: use HTTP::Request::Common;
1.1 raeburn 36: use LONCAPA::Configuration;
1.2 raeburn 37: use strict;
1.3 raeburn 38:
39: sub ims_config {
40: my ($areas,$cmsmap,$areaname) = @_;
1.35 raeburn 41: @{$areas} = ("doc","extlink","announce","staff","board","quiz","survey","pool","users","question");
1.3 raeburn 42: %{$$cmsmap{bb5}} = (
43: announce => 'resource/x-bb-announcement',
44: board => 'resource/x-bb-discussionboard',
45: doc => 'resource/x-bb-document',
46: extlink => 'resource/x-bb-externallink',
47: pool => 'assessment/x-bb-pool',
48: quiz => 'assessment/x-bb-quiz',
49: staff => 'resource/x-bb-staffinfo',
50: survey => 'assessment/x-bb-survey',
51: users => 'course/x-bb-user',
52: );
1.30 raeburn 53: %{$$cmsmap{bb6}} = (
54: announce => 'resource/x-bb-announcement',
55: board => 'resource/x-bb-discussionboard',
56: doc => 'resource/x-bb-document',
57: extlink => 'resource/x-bb-externallink',
58: pool => 'assessment/x-bb-qti-pool',
59: quiz => 'assessment/x-bb-qti-test',
60: staff => 'resource/x-bb-staffinfo',
61: survey => 'assessment/x-bb-survey',
62: users => 'course/x-bb-user',
63: );
1.10 raeburn 64: $$cmsmap{bb6}{conference} = 'resource/x-bb-conference';
1.48 raeburn 65: %{$$cmsmap{angel5}} = (
1.3 raeburn 66: board => 'BOARD',
67: extlink => 'LINK',
68: msg => 'MESSAGE',
69: quiz => 'QUIZ',
70: survey => 'FORM',
71: );
1.48 raeburn 72: @{$$cmsmap{angel5}{doc}} = ('FILE','PAGE');
1.34 raeburn 73: %{$$cmsmap{webctce4}} = (
1.15 raeburn 74: quiz => 'webctquiz',
75: survey => 'webctsurvey',
76: doc => 'webcontent'
77: );
1.35 raeburn 78: %{$$cmsmap{webctvista4}} = (
79: question => 'webct.question',
80: quiz => 'webct.assessment',
81: survey => 'webctsurvey',
82: doc => 'webcontent'
83: );
1.42 raeburn 84: %{$areaname} = &Apache::lonlocal::texthash (
1.3 raeburn 85: announce => 'Announcements',
86: board => 'Discussion Boards',
87: doc => 'Documents, pages, and folders',
88: extlink => 'Links to external sites',
89: pool => 'Question pools',
90: quiz => 'Quizzes',
1.35 raeburn 91: question => 'Assessment Questions',
1.3 raeburn 92: staff => 'Staff information',
93: survey => 'Surveys',
94: users => 'Enrollment',
95: );
96: }
1.1 raeburn 97:
98: sub create_tempdir {
1.3 raeburn 99: my ($context,$pathinfo,$timenow) = @_;
1.1 raeburn 100: my $configvars = &LONCAPA::Configuration::read_conf('loncapa.conf');
101: my $tempdir;
1.3 raeburn 102: if ($context eq 'DOCS') {
1.1 raeburn 103: $tempdir = $$configvars{'lonDaemons'}.'/tmp/'.$pathinfo;
104: if (!-e "$tempdir") {
1.2 raeburn 105: mkdir("$tempdir",0770);
106: }
107: $tempdir .= '/'.$timenow;
108: if (!-e "$tempdir") {
109: mkdir("$tempdir",0770);
110: }
1.3 raeburn 111: } elsif ($context eq "CSTR") {
1.1 raeburn 112: if (!-e "$pathinfo/temp") {
1.2 raeburn 113: mkdir("$pathinfo/temp",0770);
1.1 raeburn 114: }
115: $tempdir = $pathinfo.'/temp';
116: }
117: return $tempdir;
118: }
119:
1.3 raeburn 120: sub uploadzip {
121: my ($context,$tempdir,$source) = @_;
122: my $fname;
123: if ($context eq 'DOCS') {
1.19 albertel 124: $fname=$env{'form.uploadname.filename'};
1.3 raeburn 125: # Replace Windows backslashes by forward slashes
126: $fname=~s/\\/\//g;
127: # Get rid of everything but the actual filename
128: $fname=~s/^.*\/([^\/]+)$/$1/;
129: # Replace spaces by underscores
130: $fname=~s/\s+/\_/g;
131: # Replace all other weird characters by nothing
132: $fname=~s/[^\w\.\-]//g;
133: # See if there is anything left
134: unless ($fname) { return 'error: no uploaded file'; }
135: # Save the file
1.19 albertel 136: chomp($env{'form.uploadname'});
1.3 raeburn 137: open(my $fh,'>'.$tempdir.'/'.$fname);
1.19 albertel 138: print $fh $env{'form.uploadname'};
1.3 raeburn 139: close($fh);
140: } elsif ($context eq 'CSTR') {
141: if ($source =~ m/\/([^\/]+)$/) {
142: $fname = $1;
143: my $destination = $tempdir.'/'.$fname;
144: rename($source,$destination);
145: }
146: }
147: return $fname;
148: }
149:
1.1 raeburn 150: sub expand_zip {
151: my ($tempdir,$filename) = @_;
152: my $zipfile = "$tempdir/$filename";
1.10 raeburn 153: if (!-e "$zipfile") {
154: return 'no zip';
155: }
1.1 raeburn 156: if ($filename =~ m|\.zip$|i) {
157: open(OUTPUT, "unzip -o $zipfile -d $tempdir 2> /dev/null |");
158: close(OUTPUT);
159: } else {
160: return 'nozip';
161: }
162: if ($filename =~ m|\.zip$|i) {
163: unlink($zipfile);
164: }
165: return 'ok';
166: }
167:
168: sub process_manifest {
1.14 raeburn 169: my ($cms,$tempdir,$resources,$items,$hrefs,$resinfo,$phase,$includedres,$includeditems) = @_;
1.1 raeburn 170: my %toc = (
1.10 raeburn 171: bb6 => 'organization',
1.1 raeburn 172: bb5 => 'tableofcontents',
1.48 raeburn 173: angel5 => 'organization',
1.34 raeburn 174: webctce4 => 'organization',
1.35 raeburn 175: webctvista4 => 'organization'
1.1 raeburn 176: );
177: my @seq = "Top";
1.2 raeburn 178: %{$$items{'Top'}} = (
179: contentscount => 0,
180: resnum => 'toplevel',
181: );
1.3 raeburn 182: %{$$resources{'toplevel'}} = (
183: revitm => 'Top'
184: );
1.2 raeburn 185:
1.48 raeburn 186: if ($cms eq 'angel5') {
1.2 raeburn 187: $$resources{'toplevel'}{type} = "FOLDER";
1.10 raeburn 188: } elsif ($cms eq 'bb5' || $cms eq 'bb6') {
1.2 raeburn 189: $$resources{'toplevel'}{type} = 'resource/x-bb-document';
1.14 raeburn 190: } else {
191: $$resources{'toplevel'}{type} = 'webcontent';
1.2 raeburn 192: }
193:
1.1 raeburn 194: unless (-e "$tempdir/imsmanifest.xml") {
195: return 'nomanifest';
1.17 raeburn 196: }
1.1 raeburn 197:
198: my $xmlfile = $tempdir.'/imsmanifest.xml';
1.35 raeburn 199: &parse_manifest($cms,$phase,$tempdir,$xmlfile,\%toc,$includedres,
200: $includeditems,$items,$resources,$resinfo,$hrefs,\@seq);
201: return 'ok' ;
202: }
203:
204: sub parse_manifest {
205: my ($cms,$phase,$tempdir,$xmlfile,$toc,$includedres,$includeditems,$items,
1.52 raeburn 206: $resources,$resinfo,$hrefs,$seq,$requirer) = @_;
1.35 raeburn 207: my @state = ();
208: my $itm = '';
209: my %contents = ();
210: my $identifier = '';
211: my @allidentifiers = ();
212: my $lastitem;
1.52 raeburn 213: my $neededby;
1.1 raeburn 214: my $p = HTML::Parser->new
215: (
216: xml_mode => 1,
217: start_h =>
218: [sub {
219: my ($tagname, $attr) = @_;
220: push @state, $tagname;
1.17 raeburn 221: my $start = @state - 3;
1.35 raeburn 222: if ( ($state[0] eq "manifest") && ($state[1] eq "organizations") && ($state[2] eq $$toc{$cms}) ) {
1.17 raeburn 223: if ($state[-1] eq 'item') {
1.14 raeburn 224: $itm = $attr->{identifier};
1.16 raeburn 225: if ($$includeditems{$itm} || $phase ne 'build') {
1.14 raeburn 226: %{$$items{$itm}} = ();
227: $$items{$itm}{contentscount} = 0;
1.16 raeburn 228: @{$$items{$itm}{contents}} = ();
1.35 raeburn 229: if ($cms eq 'bb5' || $cms eq 'bb6' || $cms eq 'webctce4' || $cms eq 'webctvista4') {
1.14 raeburn 230: $$items{$itm}{resnum} = $attr->{identifierref};
231: if ($cms eq 'bb5') {
232: $$items{$itm}{title} = $attr->{title};
233: }
1.48 raeburn 234: } elsif ($cms eq 'angel5') {
1.14 raeburn 235: if ($attr->{identifierref} =~ m/^res(.+)$/) {
236: $$items{$itm}{resnum} = $1;
237: }
1.10 raeburn 238: }
1.51 raeburn 239: unless (%{$$resources{$$items{$itm}{resnum}}}) {
1.14 raeburn 240: %{$$resources{$$items{$itm}{resnum}}} = ();
1.1 raeburn 241: }
1.14 raeburn 242: $$resources{$$items{$itm}{resnum}}{revitm} = $itm;
1.35 raeburn 243: if ($start > @{$seq}) {
1.14 raeburn 244: unless ($lastitem eq '') {
1.35 raeburn 245: push @{$seq}, $lastitem;
246: unless ( defined($contents{$$seq[-1]}) ) {
247: @{$contents{$$seq[-1]}} = ();
1.14 raeburn 248: }
1.35 raeburn 249: push @{$contents{$$seq[-1]}},$itm;
250: $$items{$itm}{parentseq} = $$seq[-1];
1.14 raeburn 251: }
1.35 raeburn 252: } elsif ($start < @{$seq}) {
253: my $diff = @{$seq} - $start;
1.14 raeburn 254: while ($diff > 0) {
1.35 raeburn 255: pop @{$seq};
1.14 raeburn 256: $diff --;
257: }
1.35 raeburn 258: if (@{$seq}) {
259: push @{$contents{$$seq[-1]}}, $itm;
1.1 raeburn 260: }
1.14 raeburn 261: } else {
1.35 raeburn 262: push @{$contents{$$seq[-1]}}, $itm;
1.1 raeburn 263: }
1.14 raeburn 264: my $path;
1.35 raeburn 265: if (@{$seq} > 1) {
266: $path = join(',',@{$seq});
267: } elsif (@{$seq} > 0) {
268: $path = $$seq[0];
1.1 raeburn 269: }
1.14 raeburn 270: $$items{$itm}{filepath} = $path;
271: if ($cms eq 'bb5' || $cms eq 'bb6') {
272: if ($$items{$itm}{filepath} eq 'Top') {
273: $$items{$itm}{resnum} = $itm;
274: $$resources{$$items{$itm}{resnum}}{type} = 'resource/x-bb-document';
275: $$resources{$$items{$itm}{resnum}}{revitm} = $itm;
276: $$resinfo{$$items{$itm}{resnum}}{'isfolder'} = 'true';
277: }
1.2 raeburn 278: }
1.35 raeburn 279: $$items{$$seq[-1]}{contentscount} ++;
280: $$resources{$$items{$itm}{resnum}}{seqref} = $seq;
1.14 raeburn 281: $lastitem = $itm;
1.2 raeburn 282: }
1.1 raeburn 283: }
1.34 raeburn 284: if ($cms eq 'webctce4') {
1.17 raeburn 285: if (($state[-1] eq "webct:properties") && (@state > 4)) {
1.16 raeburn 286: $$items{$itm}{properties} = $attr->{identifierref};
287: }
288: }
1.1 raeburn 289: } elsif ("@state" eq "manifest resources resource" ) {
290: $identifier = $attr->{identifier};
1.35 raeburn 291: push(@allidentifiers,$identifier);
1.14 raeburn 292: if ($$includedres{$identifier} || $phase ne 'build') {
1.16 raeburn 293: if ($cms eq 'bb5' || $cms eq 'bb6') {
1.14 raeburn 294: $$resources{$identifier}{file} = $attr->{file};
295: $$resources{$identifier}{type} = $attr->{type};
1.34 raeburn 296: } elsif ($cms eq 'webctce4') {
1.16 raeburn 297: $$resources{$identifier}{type} = $attr->{type};
298: $$resources{$identifier}{file} = $attr->{href};
1.35 raeburn 299: } elsif ($cms eq 'webctvista4') {
300: $$resources{$identifier}{type} = $attr->{type};
301: $$resources{$identifier}{'webct:coType'} = $attr->{'webct:coType'};
1.48 raeburn 302: } elsif ($cms eq 'angel5') {
1.14 raeburn 303: $identifier = substr($identifier,3);
304: if ($attr->{href} =~ m-^_assoc/$identifier/(.+)$-) {
305: $$resources{$identifier}{file} = $1;
306: }
1.11 raeburn 307: }
1.14 raeburn 308: @{$$hrefs{$identifier}} = ();
1.1 raeburn 309: }
310: } elsif ("@state" eq "manifest resources resource file") {
1.14 raeburn 311: if ($$includedres{$identifier} || $phase ne 'build') {
1.35 raeburn 312: if ($cms eq 'bb5' || $cms eq 'bb6' ||
313: $cms eq 'webctce4' || $cms eq 'webctvista4') {
314: if ($$resources{$identifier}{type} eq
315: 'webct.manifest') {
316: my $manifestfile = $tempdir.'/'.$attr->{href};
317: my $currseqref = [];
318: if ($itm) {
319: $currseqref =
320: $$resources{$$items{$itm}{resnum}}{seqref};
321: }
322: &parse_manifest($cms,$phase,$tempdir,$manifestfile,
323: $toc,$includedres,$includeditems,
324: $items,$resources,$resinfo,
1.52 raeburn 325: $hrefs,$currseqref,$neededby);
326: } else {
327: if ($cms eq 'webctvista4') {
328: if ($$resources{$identifier}{type} eq 'ims_qtiasiv1p2') {
329: $neededby = $identifier;
330: } elsif ($$resources{$identifier}{type} eq 'webcontent') {
331: $$resources{$identifier}{usedby} = $requirer;
332: push(@{$$hrefs{$identifier}},$attr->{href});
333: }
334: $$resources{$identifier}{file} = $attr->{href};
335: } else {
336: push(@{$$hrefs{$identifier}},$attr->{href});
1.53 ! raeburn 337: }
1.35 raeburn 338: }
1.48 raeburn 339: } elsif ($cms eq 'angel5') {
1.14 raeburn 340: if ($attr->{href} =~ m/^_assoc\\$identifier\\(.+)$/) {
341: push @{$$hrefs{$identifier}},$1;
342: } elsif ($attr->{href} =~ m/^Icons\\icon(\w+)\.gif/) {
343: $$resources{$identifier}{type} = $1;
344: }
1.52 raeburn 345: }
1.35 raeburn 346: }
347: } elsif ("@state" eq "manifest webct:ContentObject") {
348: foreach my $ident (@allidentifiers) {
349: if ($$resources{$ident}{type} eq 'ims_qtiasiv1p2') {
350: $$resources{$ident}{type} = $attr->{'webct:coType'};
1.11 raeburn 351: }
1.1 raeburn 352: }
353: }
354: }, "tagname, attr"],
355: text_h =>
356: [sub {
357: my ($text) = @_;
1.15 raeburn 358: if ("@state" eq "manifest metadata lom general title langstring") {
359: $$items{'Top'}{title} = $text;
360: }
1.35 raeburn 361: if ($state[0] eq "manifest" && $state[1] eq "organizations" && $state[2] eq $$toc{$cms} && $state[-1] eq "title") {
1.14 raeburn 362: if ($$includeditems{$itm} || $phase ne 'build') {
1.48 raeburn 363: if ($cms eq 'angel5' || $cms eq 'bb6' || $cms eq 'webctvista4') {
1.14 raeburn 364: $$items{$itm}{title} = $text;
365: }
1.34 raeburn 366: if ($cms eq 'webctce4') {
1.15 raeburn 367: $$items{$itm}{title} = $text;
368: $$items{$itm}{title} =~ s/(<[^>]*>)//g;
369: }
1.4 raeburn 370: }
371: }
1.52 raeburn 372: if ("@state" eq "manifest webct:ContentObject webct:Name") {
373: if ($cms eq 'webctvista4') {
1.53 ! raeburn 374: if ($text =~ /,/) {
! 375: $$resources{$identifier}{title} = (split(/,/,$text))[-1];
! 376: } else {
! 377: $$resources{$identifier}{title} = $text;
! 378: }
1.52 raeburn 379: }
380: }
1.1 raeburn 381: }, "dtext"],
382: end_h =>
383: [sub {
384: my ($tagname) = @_;
385: pop @state;
386: }, "tagname"],
387: );
388: $p->parse_file($xmlfile);
389: $p->eof;
390: foreach my $itm (keys %contents) {
391: @{$$items{$itm}{contents}} = @{$contents{$itm}};
392: }
393: }
394:
1.14 raeburn 395: sub get_imports {
396: my ($includeditems,$items,$resources,$importareas,$itm) = @_;
397: if (exists($$items{$itm}{resnum})) {
398: if ($$importareas{$$resources{$$items{$itm}{resnum}}{type}}) {
399: unless (exists($$includeditems{$itm})) {
400: $$includeditems{$itm} = 1;
401: }
402: }
403: }
404: if ($$items{$itm}{contentscount} > 0) {
405: foreach my $child (@{$$items{$itm}{contents}}) {
406: &get_imports($includeditems,$items,$resources,$importareas,$child);
407: }
408: }
409: }
410:
411: sub get_parents {
412: my ($includeditems,$items,$itm) = @_;
413: my @pathitems = ();
414: if ($$items{$itm}{filepath} =~ m/,/) {
415: @pathitems = split/,/,$$items{$itm}{filepath};
416: } else {
417: $pathitems[0] = $$items{$itm}{filepath};
418: }
419: foreach (@pathitems) {
420: $$includeditems{$_} = 1;
421: }
422: }
423:
1.1 raeburn 424: sub target_resources {
1.2 raeburn 425: my ($resources,$oktypes,$targets) = @_;
1.52 raeburn 426: foreach my $key (sort(keys(%{$resources}))) {
1.1 raeburn 427: if ( defined($$oktypes{$$resources{$key}{type}}) ) {
1.52 raeburn 428: push(@{$targets},$key);
429: } elsif (defined($$resources{$key}{usedby})) {
430: if (defined($$oktypes{$$resources{$$resources{$key}{usedby}}{type}})) {
431: push(@{$targets},$key);
432: }
1.1 raeburn 433: }
434: }
435: return;
436: }
437:
438: sub copy_resources {
1.52 raeburn 439: my ($context,$cms,$hrefs,$resources,$tempdir,$targets,$url,$crs,$cdom,$destdir,$timenow,$assessmentfiles,$total) = @_;
1.1 raeburn 440: if ($context eq 'DOCS') {
441: foreach my $key (sort keys %{$hrefs}) {
442: if (grep/^$key$/,@{$targets}) {
1.2 raeburn 443: %{$$url{$key}} = ();
1.1 raeburn 444: foreach my $file (@{$$hrefs{$key}}) {
1.2 raeburn 445: my $source = $tempdir.'/'.$key.'/'.$file;
1.35 raeburn 446: if ($cms eq 'webctce4' || $cms eq 'webctvista4') {
1.15 raeburn 447: $source = $tempdir.'/'.$file;
448: }
1.2 raeburn 449: my $filename = '';
1.3 raeburn 450: my $fpath = $timenow.'/resfiles/'.$key.'/';
1.48 raeburn 451: if ($cms eq 'angel5') {
1.3 raeburn 452: if ($file eq 'pg'.$key.'.htm') {
453: next;
1.1 raeburn 454: }
455: }
1.3 raeburn 456: $file =~ s-\\-/-g;
1.15 raeburn 457: my $copyfile = $file;
1.35 raeburn 458: if ($cms eq 'webctce4' || $cms eq 'webctvista4') {
1.16 raeburn 459: if ($file =~ m-/my_files/(.+)$-) {
1.15 raeburn 460: $copyfile = $1;
461: }
462: }
1.52 raeburn 463: if ($cms eq 'webctvista4') {
464: if ($file =~ m{/\QX-WEBCT-VISTA-V0\E/.+([^.]+)$}) {
465: $copyfile = $1;
466: }
467: if ($$resources{$key}{usedby}) {
468: if ($$resources{$$resources{$key}{usedby}}{image} =~ /^\Q$copyfile\E/) {
469: $copyfile = $$resources{$$resources{$key}{usedby}}{image};
470: }
471: }
472: }
1.35 raeburn 473: unless ((($cms eq 'webctce4') && ($copyfile =~ m/questionDB\.xml$/ || $copyfile =~ m/quiz_QIZ_\d+\.xml$/ || $copyfile =~ m/properties_QIZ_\d+\.xml$/)) || (($cms eq 'webctvista4') && (grep/^$key$/,@{$assessmentfiles}) && $file =~ /\.xml$/)) {
1.15 raeburn 474: $copyfile = $fpath.$copyfile;
475: my $fileresult;
476: if (-e $source) {
1.31 raeburn 477: $fileresult = &Apache::lonnet::process_coursefile('copy',$crs,$cdom,$copyfile,$source);
1.15 raeburn 478: }
479: }
1.1 raeburn 480: }
481: }
482: }
483: } elsif ($context eq 'CSTR') {
484: if (!-e "$destdir/resfiles") {
1.2 raeburn 485: mkdir("$destdir/resfiles",0770);
1.1 raeburn 486: }
1.52 raeburn 487: foreach my $key (sort(keys(%{$hrefs}))) {
1.14 raeburn 488: if (grep/^$key$/,@{$targets}) {
489: foreach my $file (@{$$hrefs{$key}}) {
490: $file =~ s-\\-/-g;
1.48 raeburn 491: if ( ($cms eq 'angel5' && $file ne 'pg'.$key.'.htm') || ($cms eq 'bb5') || ($cms eq 'bb6')) {
1.14 raeburn 492: if (!-e "$destdir/resfiles/$key") {
493: mkdir("$destdir/resfiles/$key",0770);
494: }
495: my $filepath = $file;
496: my $front = '';
497: while ($filepath =~ m-(\w+)/(.+)-) {
498: $front .= $1.'/';
499: $filepath = $2;
500: my $fulldir = "$destdir/resfiles/$key/$front";
501: chop($fulldir);
502: if (!-e "$fulldir") {
503: mkdir("$fulldir",0770);
504: }
505: }
1.42 raeburn 506: my $renameres;
1.48 raeburn 507: if ($cms eq 'angel5') {
1.42 raeburn 508: $renameres = rename("$tempdir/_assoc/$key/$file","$destdir/resfiles/$key/$file");
1.14 raeburn 509: } elsif ($cms eq 'bb5' || $cms eq 'bb6') {
1.42 raeburn 510: $renameres = rename("$tempdir/$key/$file","$destdir/resfiles/$key/$file");
511: }
1.43 raeburn 512: if ($renameres) {
513: if (ref($total) eq 'HASH') {
514: $$total{'file'} ++;
515: }
516: } else {
1.42 raeburn 517: &Apache::lonnet::logthis("IMS import error: $cms - renaming failed for file $file");
1.2 raeburn 518: }
1.34 raeburn 519: } elsif ($cms eq 'webctce4') {
1.16 raeburn 520: if ($file =~ m-/my_files/(.+)$-) {
1.15 raeburn 521: my $copyfile = $1;
1.16 raeburn 522: if ($copyfile =~ m-^[^/]+/[^/]+-) {
523: my @dirs = split/\//,$copyfile;
524: my $path = "$destdir/resfiles";
525: while (@dirs > 1) {
526: $path .= '/'.$dirs[0];
527: if (!-e "$path") {
528: mkdir("$path",0755);
529: }
530: shift @dirs;
531: }
532: }
533: if (-e "$tempdir/$file") {
1.42 raeburn 534: my $renameres = rename("$tempdir/$file","$destdir/resfiles/$copyfile");
1.43 raeburn 535: if ($renameres) {
536: if (ref($total) eq 'HASH') {
537: $$total{'file'} ++;
538: }
539: } else {
1.42 raeburn 540: &Apache::lonnet::logthis("IMS import error: WebCT4 - renaming failed for file $file");
541: }
1.15 raeburn 542: }
1.17 raeburn 543: } elsif ($file !~ m-/data/(.+)$-) {
544: &Apache::lonnet::logthis("IMS import error: WebCT4 - file $file is in unexpected location");
1.15 raeburn 545: }
1.52 raeburn 546: } elsif ($cms eq 'webctvista4') {
547: if ($file =~ m{^\QX-WEBCT-VISTA-V0\E/(.+)$}) {
548: my $copyfile = $1;
549: if ($copyfile =~ m{^[^/]+/[^/]+}) {
550: my @dirs = split/\//,$copyfile;
551: my $path = "$destdir/resfiles";
552: while (@dirs > 1) {
553: $path .= '/'.$dirs[0];
554: if (!-e "$path") {
555: mkdir("$path",0755);
556: }
557: shift @dirs;
558: }
559: } else {
560: $copyfile =~ s/^[^.]+\.(\d+)_R/$1/;
561: my ($filestem,$extension) = ($copyfile =~ /^(.+)\.(\w+)$/);
562: if ($$resources{$key}{usedby}) {
563: if (ref($$resources{$$resources{$key}{usedby}}{image}) eq 'ARRAY') {
564: for (my $i=0; $i<@{$$resources{$$resources{$key}{usedby}}{image}}; $i++) {
565: my ($img,$imgtitle);
566: $img = $$resources{$$resources{$key}{usedby}}{image}[$i];
567: if (ref($$resources{$$resources{$key}{usedby}}{imagetitle}) eq 'ARRAY') {
568: $imgtitle = $$resources{$$resources{$key}{usedby}}{imagetitle}[$i];
569: }
1.53 ! raeburn 570: if ($imgtitle =~ /\Q$extension\E/i) {
! 571: $copyfile = $imgtitle;
1.52 raeburn 572: last;
573: } elsif ($img =~ /^\Q$filestem\E/i) {
574: $copyfile = $img.'.'.$extension;
575: last;
576: }
577: }
578: }
579: }
580: }
581: if (-e "$tempdir/$file") {
582: my $renameres = rename("$tempdir/$file","$destdir/resfiles/$copyfile");
583: if ($renameres) {
584: if (ref($total) eq 'HASH') {
585: $$total{'file'} ++;
586: }
587: } else {
588: &Apache::lonnet::logthis("IMS import error: WebCTVista - renaming failed for file $file");
589: }
590: }
591: }
1.2 raeburn 592: }
593: }
594: }
595: }
596: }
597: }
598:
599: sub process_resinfo {
1.15 raeburn 600: my ($cms,$context,$docroot,$destdir,$items,$resources,$targets,$boards,$announcements,$quizzes,$surveys,$pools,$groups,$messages,$timestamp,$boardnum,$resinfo,$udom,$uname,$cdom,$crs,$db_handling,$user_handling,$total,$dirname,$seqstem,$resrcfiles,$packages,$hrefs,$pagesfiles,$sequencesfiles,$randompicks) = @_;
1.2 raeburn 601: my $board_id = time;
602: my $board_count = 0;
1.15 raeburn 603: my $dbparse = 0;
1.2 raeburn 604: my $announce_handling = 'include';
605: my $longcrs = '';
1.35 raeburn 606: my %allassessments = ();
607: my %allquestions = ();
1.17 raeburn 608: my %qzdbsettings = ();
609: my %catinfo = ();
1.2 raeburn 610: if ($crs =~ m/^(\d)(\d)(\d)/) {
611: $longcrs = $1.'/'.$2.'/'.$3.'/'.$crs;
612: }
1.14 raeburn 613: if ($context eq 'CSTR') {
614: if (!-e "$destdir/resfiles") {
615: mkdir("$destdir/resfiles",0770);
616: }
617: }
1.48 raeburn 618: if ($cms eq 'angel5') {
1.2 raeburn 619: my $currboard = '';
620: foreach my $key (sort keys %{$resources}) {
1.14 raeburn 621: if (grep/^$key$/,@{$targets}) {
1.2 raeburn 622: if ($$resources{$key}{type} eq "BOARD") {
623: push @{$boards}, $key;
624: $$boardnum{$$resources{$key}{revitm}} = $board_count;
625: $currboard = $key;
626: @{$$messages{$key}} = ();
627: $$timestamp[$board_count] = $board_id;
628: $board_id ++;
629: $board_count ++;
630: } elsif ($$resources{$key}{type} eq "MESSAGE") {
631: push @{$$messages{$currboard}}, $key;
632: } elsif ($$resources{$key}{type} eq "PAGE" || $$resources{$key}{type} eq "LINK") {
633: %{$$resinfo{$key}} = ();
634: &angel_content($key,$docroot,$destdir,\%{$$resinfo{$key}},$udom,$uname,$$resources{$key}{type},$$items{$$resources{$key}{revitm}}{title},$resrcfiles);
635: } elsif ($$resources{$key}{type} eq "QUIZ") {
636: %{$$resinfo{$key}} = ();
1.3 raeburn 637: push @{$quizzes}, $key;
1.2 raeburn 638: # &angel_assessment($key,$docroot,$dirname,$destdir,\%{$$resinfo{$key}},$resrcfiles);
639: } elsif ($$resources{$key}{type} eq "FORM") {
640: %{$$resinfo{$key}} = ();
1.3 raeburn 641: push @{$surveys}, $key;
1.2 raeburn 642: # &angel_assessment($key,$docroot,$dirname,$destdir,\%{$$resinfo{$key}},$resrcfiles);
643: } elsif ($$resources{$key}{type} eq "DROPBOX") {
644: %{$$resinfo{$key}} = ();
645: }
1.14 raeburn 646: }
1.2 raeburn 647: }
1.10 raeburn 648: } elsif ($cms eq 'bb5' || $cms eq 'bb6') {
1.2 raeburn 649: foreach my $key (sort keys %{$resources}) {
1.14 raeburn 650: if (grep/^$key$/,@{$targets}) {
1.2 raeburn 651: if ($$resources{$key}{type} eq "resource/x-bb-document") {
652: unless ($$items{$$resources{$key}{revitm}}{filepath} eq 'Top') {
1.3 raeburn 653: %{$$resinfo{$key}} = ();
1.10 raeburn 654: &process_content($cms,$key,$context,$docroot,$destdir,\%{$$resinfo{$key}},$udom,$uname,$resrcfiles,$packages,$hrefs);
1.2 raeburn 655: }
656: } elsif ($$resources{$key}{type} eq "resource/x-bb-staffinfo") {
657: %{$$resinfo{$key}} = ();
1.33 raeburn 658: &process_staff($key,$docroot,$destdir,\%{$$resinfo{$key}},$resrcfiles);
1.2 raeburn 659: } elsif ($$resources{$key}{type} eq "resource/x-bb-externallink") {
660: %{$$resinfo{$key}} = ();
1.33 raeburn 661: &process_link($key,$docroot,$destdir,\%{$$resinfo{$key}},$resrcfiles);
1.2 raeburn 662: } elsif ($$resources{$key}{type} eq "resource/x-bb-discussionboard") {
663: %{$$resinfo{$key}} = ();
664: unless ($db_handling eq 'ignore') {
665: push @{$boards}, $key;
666: $$timestamp[$board_count] = $board_id;
667: &process_db($key,$docroot,$destdir,$board_id,$crs,$cdom,$db_handling,$uname,\%{$$resinfo{$key}},$longcrs);
668: $board_id ++;
669: $board_count ++;
670: }
1.30 raeburn 671: } elsif ($$resources{$key}{type} =~/assessment\/x\-bb\-(qti\-)?pool/) {
1.2 raeburn 672: %{$$resinfo{$key}} = ();
1.35 raeburn 673: &process_assessment($cms,$context,$key,$docroot,'pool',$dirname,$destdir,\%{$$resinfo{$key}},$total,$udom,$uname,$pagesfiles,$sequencesfiles,$randompicks,\$dbparse,$resources,$items,\%catinfo,\%qzdbsettings,$hrefs,\%allquestions);
1.14 raeburn 674: push @{$pools}, $key;
1.30 raeburn 675: } elsif ($$resources{$key}{type} =~ /assessment\/x\-bb\-(qti\-)?quiz/) {
1.2 raeburn 676: %{$$resinfo{$key}} = ();
1.35 raeburn 677: &process_assessment($cms,$context,$key,$docroot,'quiz',$dirname,$destdir,\%{$$resinfo{$key}},$total,$udom,$uname,$pagesfiles,$sequencesfiles,$randompicks,\$dbparse,$resources,$items,\%catinfo,\%qzdbsettings,$hrefs,\%allquestions);
1.2 raeburn 678: push @{$quizzes}, $key;
1.30 raeburn 679: } elsif ($$resources{$key}{type} =~ /assessment\/x\-bb\-(qti\-)?survey/) {
1.2 raeburn 680: %{$$resinfo{$key}} = ();
1.35 raeburn 681: &process_assessment($cms,$context,$key,$docroot,'survey',$dirname,$destdir,\%{$$resinfo{$key}},$total,$udom,$uname,$pagesfiles,$sequencesfiles,$randompicks,\$dbparse,$resources,$items,\%catinfo,\%qzdbsettings,$hrefs,\%allquestions);
1.2 raeburn 682: push @{$surveys}, $key;
683: } elsif ($$resources{$key}{type} eq "assessment/x-bb-group") {
684: %{$$resinfo{$key}} = ();
685: push @{$groups}, $key;
686: &process_group($key,$docroot,$destdir,\%{$$resinfo{$key}});
687: } elsif ($$resources{$key}{type} eq "resource/x-bb-user") {
688: %{$$resinfo{$key}} = ();
689: unless ($user_handling eq 'ignore') {
690: &process_user($key,$docroot,$destdir,\%{$$resinfo{$key}},$crs,$cdom,$user_handling);
691: }
692: } elsif ($$resources{$key}{type} eq "resource/x-bb-announcement") {
693: unless ($announce_handling eq 'ignore') {
694: push @{$announcements}, $key;
695: %{$$resinfo{$key}} = ();
1.3 raeburn 696: &process_announce($key,$docroot,$destdir,\%{$$resinfo{$key}},$resinfo,$seqstem,$resrcfiles);
1.2 raeburn 697: }
698: }
1.14 raeburn 699: }
1.2 raeburn 700: }
1.3 raeburn 701: if (@{$announcements}) {
702: $$items{'Top'}{'contentscount'} ++;
703: }
704: if (@{$boards}) {
705: $$items{'Top'}{'contentscount'} ++;
706: }
707: if (@{$quizzes}) {
708: $$items{'Top'}{'contentscount'} ++;
709: }
710: if (@{$surveys}) {
711: $$items{'Top'}{'contentscount'} ++;
712: }
1.14 raeburn 713: if (@{$pools}) {
714: $$items{'Top'}{'contentscount'} ++;
715: }
1.34 raeburn 716: } elsif ($cms eq 'webctce4') {
1.15 raeburn 717: foreach my $key (sort keys %{$resources}) {
718: if (grep/^$key$/,@{$targets}) {
719: if ($$resources{$key}{type} eq "webcontent") {
720: %{$$resinfo{$key}} = ();
1.44 raeburn 721: if ($$resources{$key}{file} eq 'questiondb.xml') {
722: &process_assessment($cms,$context,$key,$docroot,'quiz',$dirname,$destdir,\%{$$resinfo{$key}},$total,$udom,$uname,$pagesfiles,$sequencesfiles,$randompicks,\$dbparse,$resources,$items,\%catinfo,\%qzdbsettings,$hrefs,\%allquestions);
723: } else {
724: &webct4_content($key,$docroot,$destdir,\%{$$resinfo{$key}},$udom,$uname,$$resources{$key}{type},$$items{$$resources{$key}{revitm}}{title},$resrcfiles);
725: }
1.15 raeburn 726: } elsif ($$resources{$key}{type} eq "webctquiz") {
1.35 raeburn 727: &process_assessment($cms,$context,$key,$docroot,'quiz',$dirname,$destdir,\%{$$resinfo{$key}},$total,$udom,$uname,$pagesfiles,$sequencesfiles,$randompicks,\$dbparse,$resources,$items,\%catinfo,\%qzdbsettings,$hrefs,\%allquestions);
728: }
729: }
730: }
731: } elsif ($cms eq 'webctvista4') {
732: foreach my $key (sort keys %{$resources}) {
733: if (grep/^$key$/,@{$targets}) {
734: %{$$resinfo{$key}} = ();
735: if ($$resources{$key}{type} eq 'webct.question') {
736: $allquestions{$key} = 1;
737: } elsif ($$resources{$key}{type} eq 'webct.assessment') {
738: $allassessments{$key} = 1;
1.15 raeburn 739: }
740: }
741: }
1.35 raeburn 742: if (keys(%allassessments) > 0) {
743: foreach my $key (sort(keys(%allassessments))) {
744: &process_assessment($cms,$context,$key,$docroot,'quiz',$dirname,$destdir,\%{$$resinfo{$key}},$total,$udom,$uname,$pagesfiles,$sequencesfiles,$randompicks,\$dbparse,$resources,$items,\%catinfo,\%qzdbsettings,$hrefs,\%allquestions);
745: }
746: } elsif (keys(%allquestions) > 0) {
747: my %catinfo = ();
748: my @allids = ();
749: my @allquestids = ();
750: my %allanswers = ();
751: my %allchoices = ();
752: my $containerdir;
753: my $newdir;
754: my $cid;
755: my $randompickflag = 0;
756: if ($context eq 'DOCS') {
757: $cid = $env{'request.course.id'};
758: }
759: my $destresdir = $destdir;
1.50 raeburn 760: my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
1.35 raeburn 761: if ($context eq 'CSTR') {
1.50 raeburn 762: $destresdir =~ s{^\Q$londocroot/priv/\E}{/res/};
1.35 raeburn 763: } elsif ($context eq 'DOCS') {
1.50 raeburn 764: $destresdir =~ s{^\Q$londocroot/userfiles\E}{/uploaded};
1.35 raeburn 765: }
766: foreach my $res (sort(keys(%allquestions))) {
767: my $parent = $allquestions{$res};
768: &parse_webctvista4_question($res,$docroot,$resources,$hrefs,\%qzdbsettings,\@allquestids,\%allanswers,\%allchoices,$parent,\%catinfo);
769: }
770: &build_category_sequences($destdir,\%catinfo,$sequencesfiles,$pagesfiles,$destresdir,$newdir,$cms,$total,$randompickflag,$context,$udom,$uname,$dirname,$cid,$cdom,$crs,\%qzdbsettings);
771: &write_webct4_questions($cms,\@allquestids,$context,\%qzdbsettings,$dirname,\%allanswers,\%allchoices,$total,$cid,$cdom,$crs,$destdir,\%catinfo);
772: }
1.2 raeburn 773: }
1.3 raeburn 774:
1.2 raeburn 775: $$total{'board'} = $board_count;
1.3 raeburn 776: $$total{'quiz'} = @{$quizzes};
777: $$total{'surv'} = @{$surveys};
1.14 raeburn 778: $$total{'pool'} = @{$pools};
1.2 raeburn 779: }
780:
781: sub build_structure {
1.15 raeburn 782: my ($cms,$context,$destdir,$items,$resinfo,$resources,$targets,$hrefs,$udom,$uname,$newdir,$timenow,$cdom,$crs,$timestamp,$total,$boards,$announcements,$quizzes,$surveys,$pools,$boardnum,$pagesfiles,$seqfiles,$topurls,$topnames,$packages,$includeditems,$randompicks) = @_;
1.2 raeburn 783: my %flag = ();
784: my %count = ();
785: my %pagecontents = ();
786: my %seqtext = ();
787: my $topnum = 0;
1.14 raeburn 788: my $topspecials = @$announcements + @$boards + @$quizzes + @$surveys + @$pools;
1.2 raeburn 789:
790: if (!-e "$destdir") {
791: mkdir("$destdir",0755);
792: }
793: if (!-e "$destdir/sequences") {
794: mkdir("$destdir/sequences",0770);
795: }
796: if (!-e "$destdir/resfiles") {
797: mkdir("$destdir/resfiles",0770);
798: }
799: if (!-e "$destdir/pages") {
800: mkdir("$destdir/pages",0770);
801: }
802: if (!-e "$destdir/problems") {
803: mkdir("$destdir/problems",0770);
804: }
805:
806: $seqtext{'Top'} = qq|<map>\n|;
807: %{$$resinfo{$$items{'Top'}{resnum}}} = (
808: isfolder => 'true',
809: );
810:
811: my $srcstem = "";
812:
813: if ($context eq 'DOCS') {
814: $srcstem = "/uploaded/$cdom/$crs/$timenow";
815: } elsif ($context eq 'CSTR') {
816: $srcstem = "/res/$udom/$uname/$newdir";
817: }
818:
819: foreach my $key (sort keys %{$items}) {
1.14 raeburn 820: if ($$includeditems{$key}) {
1.2 raeburn 821: %{$flag{$key}} = (
822: page => 0,
823: seq => 0,
824: board => 0,
825: file => 0,
826: );
827:
828: %{$count{$key}} = (
829: page => -1,
830: seq => 0,
831: board => 0,
832: file => 0,
833: );
834:
835: my $src = "";
836:
837: my $next_id = 2;
838: my $curr_id = 1;
839: my $resnum = $$items{$key}{resnum};
840: my $type = $$resources{$resnum}{type};
1.42 raeburn 841: my $contentscount = $$items{$key}{'contentscount'};
842: my $seqtitle = $$items{$key}{'title'};
843: $seqtitle =~ s|/+|_|g;
844: $seqtitle =~ s/\s+/_/g;
845: $seqtitle .= '_'.$key;
1.48 raeburn 846: if (($cms eq 'angel5' && $type eq "FOLDER") || (($cms eq 'bb5' || $cms eq 'bb6') && $$resinfo{$resnum}{'isfolder'} eq "true") && (($type eq "resource/x-bb-document") || ($type eq "resource/x-bb-staffinfo") || ($type eq "resource/x-bb-externallink")) || ($cms eq 'webctce4' && $contentscount > 0)) {
1.10 raeburn 847: unless (($cms eq 'bb5') && $key eq 'Top') {
1.2 raeburn 848: $seqtext{$key} = "<map>\n";
849: }
1.15 raeburn 850: if ($contentscount == 0) {
1.14 raeburn 851: if ($key eq 'Top') {
852: unless ($topspecials) {
853: $seqtext{$key} .= qq|<resource id="$curr_id" src="" type="start"></resource>
854: <link from="$curr_id" to="$next_id" index="$curr_id"></link>
855: <resource id="$next_id" src="" type="finish"></resource>\n|;
856: }
857: } else {
858: $seqtext{$key} .= qq|<resource id="$curr_id" src="" type="start"></resource>
1.2 raeburn 859: <link from="$curr_id" to="$next_id" index="$curr_id"></link>
860: <resource id="$next_id" src="" type="finish"></resource>\n|;
1.14 raeburn 861: }
1.2 raeburn 862: } else {
1.16 raeburn 863: my $contcount = 0;
864: if (defined($$items{$key}{contents})) {
865: $contcount = @{$$items{$key}{contents}};
866: } else {
1.17 raeburn 867: &Apache::lonnet::logthis("IMS Import error for item: $key- contents count = $contentscount, but identity of contents not defined.");
1.16 raeburn 868: }
1.2 raeburn 869: my $contitem = $$items{$key}{contents}[0];
1.15 raeburn 870: my $contitemcount = $$items{$contitem}{contentscount};
1.16 raeburn 871: my ($res,$itm,$type,$file);
1.15 raeburn 872: if (exists($$items{$contitem}{resnum})) {
873: $res = $$items{$contitem}{resnum};
874: $itm = $$resources{$res}{revitm};
875: $type = $$resources{$res}{type};
1.16 raeburn 876: $file = $$resources{$res}{file};
1.15 raeburn 877: }
1.2 raeburn 878: my $title = $$items{$contitem}{title};
1.10 raeburn 879: my $packageflag = 0;
880: if (grep/^$res$/,@{$packages}) {
881: $packageflag = 1;
882: }
1.42 raeburn 883: $src = &make_structure($cms,$key,$srcstem,\%flag,\%count,$timestamp,$boardnum,$hrefs,\%pagecontents,$res,$type,$file,$resinfo,$contitem,$uname,$cdom,$contcount,$packageflag,$contitemcount,$$randompicks{$contitem},$title);
1.2 raeburn 884: unless ($flag{$key}{page} == 1) {
1.18 raeburn 885: if ($$randompicks{$contitem}) {
886: $seqtext{$key} .= qq|
887: <param to="$curr_id" type="int_pos" name="parameter_randompick" value="$$randompicks{$contitem}"></param>\n|;
888: }
1.5 raeburn 889: $seqtext{$key} .= qq|<resource id="$curr_id" src="$src" title="$title" type="start"|;
1.2 raeburn 890: unless ($flag{$key}{seq} || $flag{$key}{board} || $flag{$key}{file}) {
891: $flag{$key}{page} = 1;
892: }
893: if ($key eq 'Top') {
894: push @{$topurls}, $src;
895: push @{$topnames}, $title;
896: }
897: }
898: if ($contcount == 1) {
899: $seqtext{$key} .= qq|></resource>
1.14 raeburn 900: <link from="$curr_id" to="$next_id" index="$curr_id"></link>|;
901: if ($key eq 'Top') {
902: unless ($topspecials) {
903: $seqtext{$key} .= qq|
904: <resource id="$next_id" src="" type="finish"></resource>\n|;
905: }
906: } else {
907: $seqtext{$key} .= qq|
1.2 raeburn 908: <resource id="$next_id" src="" type="finish"></resource>\n|;
1.14 raeburn 909: }
1.2 raeburn 910: } else {
911: if ($contcount > 2 ) {
912: for (my $i=1; $i<$contcount-1; $i++) {
913: my $contitem = $$items{$key}{contents}[$i];
1.15 raeburn 914: my $contitemcount = $$items{$contitem}{contentscount};
1.2 raeburn 915: my $res = $$items{$contitem}{resnum};
916: my $type = $$resources{$res}{type};
1.16 raeburn 917: my $file = $$resources{$res}{file};
1.10 raeburn 918: my $title = $$items{$contitem}{title};
919: my $packageflag = 0;
920: if (grep/^$res$/,@{$packages}) {
921: $packageflag = 1;
922: }
1.42 raeburn 923: $src = &make_structure($cms,$key,$srcstem,\%flag,\%count,$timestamp,$boardnum,$hrefs,\%pagecontents,$res,$type,$file,$resinfo,$contitem,$uname,$cdom,$contcount,$packageflag,$contitemcount,$$randompicks{$contitem},$title);
1.2 raeburn 924: unless ($flag{$key}{page} == 1) {
925: $seqtext{$key} .= qq|></resource>
1.18 raeburn 926: <link from="$curr_id" to="$next_id" index="$curr_id"></link>\n|;
927: if ($$randompicks{$contitem}) {
928: $seqtext{$key} .= qq|
929: <param to="$next_id" type="int_pos" name="parameter_randompick" value="$$randompicks{$contitem}"></param>|;
930: }
931: $seqtext{$key} .= qq|
1.2 raeburn 932: <resource id="$next_id" src="$src" title="$title"|;
933: $curr_id ++;
934: $next_id ++;
935: unless ($flag{$key}{seq} || $flag{$key}{board} || $flag{$key}{file}) {
936: $flag{$key}{page} = 1;
937: }
938: if ($key eq 'Top') {
939: push @{$topurls}, $src;
940: push @{$topnames}, $title;
941: }
942: }
943: }
944: }
945: my $contitem = $$items{$key}{contents}[-1];
1.15 raeburn 946: my $contitemcount = $$items{$contitem}{contentscount};
1.2 raeburn 947: my $res = $$items{$contitem}{resnum};
948: my $type = $$resources{$res}{type};
1.16 raeburn 949: my $file = $$resources{$res}{file};
1.2 raeburn 950: my $title = $$items{$contitem}{title};
1.10 raeburn 951: my $packageflag = 0;
952: if (grep/^$res$/,@{$packages}) {
953: $packageflag = 1;
954: }
1.42 raeburn 955: $src = &make_structure($cms,$key,$srcstem,\%flag,\%count,$timestamp,$boardnum,$hrefs,\%pagecontents,$res,$type,$file,$resinfo,$contitem,$uname,$cdom,$contcount,$packageflag,$contitemcount,$$randompicks{$contitem},$title);
1.15 raeburn 956:
1.2 raeburn 957: if ($flag{$key}{page}) {
958: if ($count{$key}{seq} + $count{$key}{page} + $count{$key}{board} + $count{$key}{file} +1 == 1) {
959: $seqtext{$key} .= qq|></resource>
960: <link from="$curr_id" index="$curr_id" to="$next_id">
961: <resource id ="$next_id" src="" |;
962: }
963: } else {
964: $seqtext{$key} .= qq|></resource>
1.18 raeburn 965: <link from="$curr_id" to="$next_id" index="$curr_id"></link>\n|;
966: if ($$randompicks{$contitem}) {
967: $seqtext{$key} .= qq|
968: <param to="$next_id" type="int_pos" name="parameter_randompick" value="$$randompicks{$contitem}"></param>\n|;
969: }
970: $seqtext{$key} .= qq|
1.2 raeburn 971: <resource id="$next_id" src="$src" title="$title" |;
972: if ($key eq 'Top') {
973: push @{$topurls}, $src;
974: push @{$topnames}, $title;
975: }
976: }
977: if ($contcount == $$items{$key}{contentscount}) {
978: $seqtext{$key} .= qq|type="finish"></resource>\n|;
979: } else {
980: $curr_id ++;
981: $next_id ++;
982: $seqtext{$key} .= qq|></resource>
1.8 raeburn 983: <link from="$curr_id" to="$next_id" index="$curr_id"></link>\n|;
1.2 raeburn 984: }
985: }
986: }
1.10 raeburn 987: unless (($cms eq 'bb5') && $key eq 'Top') {
1.2 raeburn 988: $seqtext{$key} .= "</map>\n";
1.42 raeburn 989: if ($cms eq 'webctce4' && $key ne 'Top') {
990: push @{$seqfiles}, "$seqtitle.sequence";
991: open(LOCFILE,">$destdir/sequences/$seqtitle.sequence");
992: } else {
993: push @{$seqfiles}, "$key.sequence";
994: open(LOCFILE,">$destdir/sequences/$key.sequence");
995: }
1.2 raeburn 996: print LOCFILE $seqtext{$key};
997: close(LOCFILE);
998: }
999: $count{$key}{page} ++;
1000: $$total{page} += $count{$key}{page};
1001: }
1002: $$total{seq} += $count{$key}{seq};
1.14 raeburn 1003: }
1.2 raeburn 1004: }
1005: $topnum += ($count{'Top'}{page} + $count{'Top'}{seq});
1006:
1.10 raeburn 1007: if ($cms eq 'bb5' || $cms eq 'bb6') {
1.2 raeburn 1008: if (@{$announcements} > 0) {
1009: &process_specials($context,'announcements',$announcements,\$topnum,$$items{'Top'}{contentscount},$destdir,$udom,$uname,$cdom,$crs,$timenow,$newdir,$timestamp,$resinfo,\$seqtext{'Top'},$pagesfiles,$seqfiles,$topurls,$topnames);
1010: }
1011: if (@{$boards} > 0) {
1012: &process_specials($context,'boards',$boards,\$topnum,$$items{'Top'}{contentscount},$destdir,$udom,$uname,$cdom,$crs,$timenow,$newdir,$timestamp,$resinfo,\$seqtext{'Top'},$pagesfiles,$seqfiles,$topurls,$topnames);
1013: }
1014: if (@{$quizzes} > 0) {
1015: &process_specials($context,'quizzes',$quizzes,\$topnum,$$items{'Top'}{contentscount},$destdir,$udom,$uname,$cdom,$crs,$timenow,$newdir,$timestamp,$resinfo,\$seqtext{'Top'},$pagesfiles,$seqfiles,$topurls,$topnames);
1016: }
1017: if (@{$surveys} > 0) {
1018: &process_specials($context,'surveys',$surveys,\$topnum,$$items{'Top'}{contentscount},$destdir,$udom,$uname,$cdom,$crs,$timenow,$newdir,$timestamp,$resinfo,\$seqtext{'Top'},$pagesfiles,$seqfiles,$topurls,$topnames);
1019: }
1.14 raeburn 1020: if (@{$pools} > 0) {
1021: &process_specials($context,'pools',$pools,\$topnum,$$items{'Top'}{contentscount},$destdir,$udom,$uname,$cdom,$crs,$timenow,$newdir,$timestamp,$resinfo,\$seqtext{'Top'},$pagesfiles,$seqfiles,$topurls,$topnames);
1022: }
1.2 raeburn 1023: $seqtext{'Top'} .= "</map>\n";
1024: open(TOPFILE,">$destdir/sequences/Top.sequence");
1025: print TOPFILE $seqtext{'Top'};
1026: close(TOPFILE);
1027: push @{$seqfiles}, 'Top.sequence';
1028: }
1029:
1030: my $filestem;
1031: if ($context eq 'DOCS') {
1.6 raeburn 1032: $filestem = "/uploaded/$cdom/$crs/$timenow";
1.2 raeburn 1033: } elsif ($context eq 'CSTR') {
1034: $filestem = "/res/$udom/$uname/$newdir";
1035: }
1036:
1037: foreach my $key (sort keys %pagecontents) {
1038: for (my $i=0; $i<@{$pagecontents{$key}}; $i++) {
1039: my $filename = $destdir.'/pages/'.$key.'_'.$i.'.page';
1.10 raeburn 1040: my $resource = "$filestem/resfiles/$$items{$pagecontents{$key}[$i][0]}{resnum}.html";
1041: my $res = $$items{$pagecontents{$key}[$i][0]}{resnum};
1042: my $resource = $filestem.'/resfiles/'.$res.'.html';
1043: if (grep/^$res$/,@{$packages}) {
1044: $resource = $filestem.'/resfiles/'.$res.'./index.html'; # should be entry_point
1045: }
1.2 raeburn 1046: open(PAGEFILE,">$filename");
1047: print PAGEFILE qq|<map>
1.10 raeburn 1048: <resource src="$resource" id="1" type="start" title="$$items{$pagecontents{$key}[$i][0]}{title}"></resource>
1.2 raeburn 1049: <link to="2" index="1" from="1">\n|;
1050: if (@{$pagecontents{$key}[$i]} == 1) {
1.3 raeburn 1051: print PAGEFILE qq|<resource src="" id="2" type="finish"></resource>\n|;
1.2 raeburn 1052: } elsif (@{$pagecontents{$key}[$i]} == 2) {
1.10 raeburn 1053: my $res = $$items{$pagecontents{$key}[$i][1]}{resnum};
1054: my $resource = $filestem.'/resfiles/'.$res.'.html';
1055: if (grep/^$res$/,@{$packages}) {
1056: $resource = $filestem.'/resfiles/'.$res.'./index.html'; # should be entry_point
1057: }
1058: print PAGEFILE qq|<resource src="$resource" id="2" type="finish" title="$$items{$pagecontents{$key}[$i][1]}{title}"></resource>\n|;
1.2 raeburn 1059: } else {
1060: for (my $j=1; $j<@{$pagecontents{$key}[$i]}-1; $j++) {
1061: my $curr_id = $j+1;
1062: my $next_id = $j+2;
1.10 raeburn 1063: my $res = $$items{$pagecontents{$key}[$i][$j]}{resnum};
1064: my $resource = $filestem.'/resfiles/'.$res.'.html';
1065: if (grep/^$res$/,@{$packages}) {
1066: $resource = $filestem.'/resfiles/'.$res.'./index.html'; # entry_point
1067: }
1.2 raeburn 1068: print PAGEFILE qq|<resource src="$resource" id="$curr_id" title="$$items{$pagecontents{$key}[$i][$j]}{title}"></resource>
1069: <link to="$next_id" index="$curr_id" from="$curr_id">\n|;
1070: }
1071: my $final_id = @{$pagecontents{$key}[$i]};
1.10 raeburn 1072: my $res = $$items{$pagecontents{$key}[$i][-1]}{resnum};
1073: my $resource = $filestem.'/resfiles/'.$res.'.html';
1074: if (grep/^$res$/,@{$packages}) {
1075: $resource = $filestem.'/resfiles/'.$res.'./index.html'; # entry_point
1076: }
1077: print PAGEFILE qq|<resource src="$resource" id="$final_id" type="finish" title="$$items{$pagecontents{$key}[$i][-1]}{title}"></resource>\n|;
1.2 raeburn 1078: }
1079: print PAGEFILE "</map>";
1080: close(PAGEFILE);
1081: push @{$pagesfiles}, $key.'_'.$i.'.page';
1082: }
1083: }
1084: }
1085:
1086: sub make_structure {
1.42 raeburn 1087: my ($cms,$key,$srcstem,$flag,$count,$timestamp,$boardnum,$hrefs,$pagecontents,$res,$type,$file,$resinfo,$contitem,$uname,$cdom,$contcount,$packageflag,$contitemcount,$randompick,$title) = @_;
1.2 raeburn 1088: my $src ='';
1.48 raeburn 1089: if (($cms eq 'angel5' && $type eq 'FOLDER') || (($cms eq 'bb5' || $cms eq 'bb6') && (($$resinfo{$res}{'isfolder'} eq 'true') || $key eq 'Top')) || ($cms eq 'webctce4' && $contitemcount > 0)) {
1.2 raeburn 1090: $src = $srcstem.'/sequences/'.$contitem.'.sequence';
1.42 raeburn 1091: if ($cms eq 'webctce4') {
1092: $title =~ s|/+|_|g;
1093: $title =~ s/\s+/_/g;
1094: $title .= '_'.$contitem;
1095: $src = $srcstem.'/sequences/'.$title.'.sequence';
1096: }
1.2 raeburn 1097: $$flag{$key}{page} = 0;
1098: $$flag{$key}{seq} = 1;
1099: $$count{$key}{seq} ++;
1.34 raeburn 1100: } elsif ($cms eq 'webctce4' && $randompick) {
1.18 raeburn 1101: $src = $srcstem.'/sequences/'.$res.'.sequence';
1102: $$flag{$key}{page} = 0;
1103: $$flag{$key}{seq} = 1;
1104: $$count{$key}{seq} ++;
1.48 raeburn 1105: } elsif ($cms eq 'angel5' && $type eq 'BOARD') {
1.2 raeburn 1106: $src = '/adm/'.$cdom.'/'.$uname.'/'.$$timestamp[$$boardnum{$res}].'/bulletinboard';
1107: $$flag{$key}{page} = 0;
1108: $$flag{$key}{board} = 1;
1109: $$count{$key}{board} ++;
1.48 raeburn 1110: } elsif ($cms eq 'angel5' && $type eq "FILE") {
1.2 raeburn 1111: foreach my $file (@{$$hrefs{$res}}) {
1112: unless ($file eq 'pg'.$res.'.htm') {
1113: $src = $srcstem.'/resfiles/'.$res.'/'.$file;
1114: }
1115: }
1116: $$flag{$key}{page} = 0;
1117: $$flag{$key}{file} = 1;
1.48 raeburn 1118: } elsif ($cms eq 'angel5' && (($type eq "PAGE") || ($type eq "LINK")) ) {
1.2 raeburn 1119: if ($$flag{$key}{page}) {
1.3 raeburn 1120: if ($$count{$key}{page} == -1) {
1.17 raeburn 1121: &Apache::lonnet::logthis("IMS Angel import error in array index for page: value = -1, resource is $key, type is $type.");
1.2 raeburn 1122: } else {
1123: push @{$$pagecontents{$key}[$$count{$key}{page}]},$contitem;
1124: }
1125: } else {
1126: $$count{$key}{page} ++;
1127: $src = $srcstem.'/pages/'.$key.'_'.$$count{$key}{page}.'.page';
1128: @{$$pagecontents{$key}[$$count{$key}{page}]} = ("$contitem");
1129: $$flag{$key}{seq} = 0;
1130: }
1.10 raeburn 1131: } elsif ($cms eq 'bb5' || $cms eq 'bb6') {
1.2 raeburn 1132: if ($$flag{$key}{page}) {
1133: push @{$$pagecontents{$key}[$$count{$key}{page}]},$contitem;
1134: } else {
1.10 raeburn 1135: if ($contcount == 1) {
1136: if ($packageflag) {
1137: $src = $srcstem.'/resfiles/'.$res.'/index.html'; # Needs to be entry point
1138: } else {
1139: $src = $srcstem.'/resfiles/'.$res.'.html';
1140: }
1141: } else {
1142: $$count{$key}{page} ++;
1143: $src = $srcstem.'/pages/'.$key.'_'.$$count{$key}{page}.'.page';
1144: @{$$pagecontents{$key}[$$count{$key}{page}]} = ("$contitem");
1145: }
1.2 raeburn 1146: $$flag{$key}{seq} = 0;
1147: }
1.34 raeburn 1148: } elsif ($cms eq 'webctce4') {
1.17 raeburn 1149: if ($type eq 'webctquiz') {
1150: $src = $srcstem.'/pages/'.$res.'.page';
1.18 raeburn 1151: $$count{$key}{page} ++;
1152: $$flag{$key}{seq} = 0;
1.17 raeburn 1153: } else {
1.16 raeburn 1154: if (grep/^$file$/,@{$$hrefs{$res}}) {
1.15 raeburn 1155: my $filename;
1156: if ($file =~ m-/([^/]+)$-) {
1157: $filename = $1;
1158: }
1.42 raeburn 1159: $src = $srcstem.'/resfiles/'.$filename;
1.16 raeburn 1160: } else {
1161: foreach my $file (@{$$hrefs{$res}}) {
1162: my $filename;
1.42 raeburn 1163: if ($file =~ m-/my_files/(.+)$-) {
1164: $filename = $1;
1165: } elsif ($file =~ m-/([^/]+)$-) {
1.16 raeburn 1166: $filename = $1;
1167: }
1.42 raeburn 1168: $src = $srcstem.'/resfiles/'.$filename;
1.16 raeburn 1169: }
1.15 raeburn 1170: }
1171: $$flag{$key}{page} = 0;
1172: $$flag{$key}{file} = 1;
1173: }
1.2 raeburn 1174: }
1175: return $src;
1176: }
1177:
1178:
1179: # ---------------------------------------------------------------- Process Blackboard specials - announcements, bulletin boards, quizzes and surveys
1180: sub process_specials {
1181: my ($context,$type,$specials,$topnum,$contentscount,$destdir,$udom,$uname,$cdom,$crs,$timenow,$newdir,$timestamp,$resinfo,$seqtext,$pagesfiles,$seqfiles,$topurls,$topnames) = @_;
1182: my $src = '';
1183: my $specialsrc = '';
1184: my $nextnum = 0;
1185: my $seqstem = '';
1186: if ($context eq 'CSTR') {
1.3 raeburn 1187: $seqstem = "/res/$udom/$uname/$newdir";
1.2 raeburn 1188: } elsif ($context eq 'DOCS') {
1189: $seqstem = '/uploaded/'.$cdom.'/'.$crs.'/'.$timenow;
1190: }
1191: my %seqnames = (
1192: boards => 'bulletinboards',
1193: quizzes => 'quizzes',
1194: surveys => 'surveys',
1195: announcements => 'announcements',
1.14 raeburn 1196: pools => 'pools'
1.2 raeburn 1197: );
1198: my %seqtitles = (
1.47 bisitz 1199: boards => 'Course Discussion Boards',
1.2 raeburn 1200: quizzes => 'Course Quizzes',
1201: surveys => 'Course Surveys',
1202: announcements => 'Course Announcements',
1.14 raeburn 1203: pools => 'Course Question Pools'
1.2 raeburn 1204: );
1205: $$topnum ++;
1206:
1207: if ($type eq 'announcements') {
1208: $src = "$seqstem/pages/$seqnames{$type}.page";
1209: } else {
1210: $src = "$seqstem/sequences/$seqnames{$type}.sequence";
1211: }
1212:
1213: push @{$topurls}, $src;
1214: push @{$topnames}, $seqtitles{$type};
1215:
1216: $$seqtext .= qq|<resource id="$$topnum" src="$src" title="$seqtitles{$type}"|;
1217: $nextnum = $$topnum +1;
1218: if ($$topnum == 1) {
1219: $$seqtext .= qq| type="start"></resource>
1220: <link from="$$topnum" to="$nextnum" index="$$topnum"></link>\n|;
1221: if ($$topnum == $contentscount) {
1222: $$seqtext .= qq|<resource id="$nextnum" src="" type="finish"></resource>\n|;
1223: }
1224: } else {
1225: if ($$topnum == $contentscount) {
1226: $$seqtext .= qq| type="finish"></resource>\n|;
1227: } else {
1228: $$seqtext .= qq|></resource>
1229: <link from="$$topnum" to="$nextnum" index="$$topnum"></link>\n|;
1230: }
1231: }
1232:
1233: if ($type eq "announcements") {
1234: push @{$pagesfiles}, "$seqnames{$type}.page";
1235: open(ITEM,">$destdir/pages/$seqnames{$type}.page");
1236: } else {
1237: push @{$seqfiles}, "$seqnames{$type}.sequence";
1238: open(ITEM,">$destdir/sequences/$seqnames{$type}.sequence");
1239: }
1240:
1241: if ($type eq 'boards') {
1242: $specialsrc = "/adm/$udom/$uname/$$timestamp[0]/bulletinboard";
1243: } elsif ($type eq 'announcements') {
1244: $specialsrc = "$seqstem/resfiles/$$specials[0].html";
1.14 raeburn 1245: } elsif ($type eq 'pools') {
1246: $specialsrc = "$seqstem/sequences/$$specials[0].sequence";
1.2 raeburn 1247: } else {
1248: $specialsrc = "$seqstem/pages/$$specials[0].page";
1249: }
1250: print ITEM qq|<map>
1251: <resource id="1" src="$specialsrc" title="$$resinfo{$$specials[0]}{title}" type="start"></resource>
1252: <link from="1" to="2" index="1"></link>|;
1253: if (@{$specials} == 1) {
1254: print ITEM qq|
1255: <resource id="2" src="" type="finish"></resource>\n|;
1256: } else {
1257: for (my $i=1; $i<@{$specials}; $i++) {
1258: my $curr = $i+1;
1259: my $next = $i+2;
1260: if ($type eq 'boards') {
1261: $specialsrc = "/adm/$udom/$uname/$$timestamp[$i]/bulletinboard";
1262: } elsif ($type eq 'announcements') {
1263: $specialsrc = "$seqstem/resfiles/$$specials[$i].html";
1264: } else {
1265: $specialsrc = "$seqstem/pages/$$specials[$i].page";
1266: }
1267: print ITEM qq|<resource id="$curr" src="$specialsrc" title="$$resinfo{$$specials[$i]}{title}"|;
1268: if (@{$specials} == $i+1) {
1269: print ITEM qq| type="finish"></resource>\n|;
1270: } else {
1271: print ITEM qq|></resource>
1272: <link from="$curr" to="$next" index="$next">\n|;
1273: }
1274: }
1275: }
1276: print ITEM qq|</map>|;
1277: close(ITEM);
1278: }
1279:
1280: # ---------------------------------------------------------------- Process Blackboard users
1281: sub process_user {
1282: my ($res,$docroot,$destdir,$settings,$user_crs,$user_cdom,$user_handling) = @_;
1283: my $xmlfile = $docroot.'/'.$res.".dat";
1284: my $filecount = 0;
1285: my @state;
1286: my $userid = '';
1287: my $linknum = 0;
1288:
1289: my $p = HTML::Parser->new
1290: (
1291: xml_mode => 1,
1292: start_h =>
1293: [sub {
1294: my ($tagname, $attr) = @_;
1295: push @state, $tagname;
1.7 raeburn 1296: if ("@state" eq "USERS USER") {
1.2 raeburn 1297: $userid = $attr->{value};
1298: %{$$settings{$userid}} = ();
1299: @{$$settings{$userid}{links}} = ();
1.7 raeburn 1300: } elsif ("@state" eq "USERS USER LOGINID") {
1.2 raeburn 1301: $$settings{$userid}{loginid} = $attr->{value};
1.7 raeburn 1302: } elsif ("@state" eq "USERS USER PASSPHRASE") {
1.2 raeburn 1303: $$settings{$userid}{passphrase} = $attr->{value};
1304: } elsif ("@state" eq "USERS USER STUDENTID" ) {
1305: $$settings{$userid}{studentid} = $attr->{value};
1306: } elsif ("@state" eq "USERS USER NAMES FAMILY" ) {
1307: $$settings{$userid}{family} = $attr->{value};
1308: } elsif ("@state" eq "USERS USER NAMES GIVEN" ) {
1309: $$settings{$userid}{given} = $attr->{value};
1310: } elsif ("@state" eq "USERS USER ADDRESSES BUSINESS DATA EMAIL") {
1311: $$settings{$userid}{email} = $attr->{value};
1312: } elsif ("@state" eq "USERS USER USER_ROLE") {
1313: $$settings{$userid}{user_role} = $attr->{value};
1314: } elsif ("@state" eq "USERS USER FLAGS ISAVAILABLE") {
1315: $$settings{$userid}{isavailable} = $attr->{value};
1316: } elsif ("@state" eq "USERS USER PERSONALPAGE FILELIST IMAGE") {
1317: $$settings{$userid}{image} = $attr->{value};
1318: } elsif ( ($state[-2] eq "LINKLIST") && ($state[-1] eq "LINK") ) {
1319: %{$$settings{$userid}{links}[$linknum]} = ();
1320: $$settings{$userid}{links}[$linknum]{url} = $attr->{value};
1321: $linknum ++;
1322: }
1323: }, "tagname, attr"],
1324: text_h =>
1325: [sub {
1326: my ($text) = @_;
1327: if ("@state" eq "USERS USER PERSONALPAGE TITLE") {
1328: $$settings{$userid}{title} = $text;
1329: } elsif ("@state" eq "USERS USER PERSONALPAGE DESCRIPTION") {
1330: $$settings{$userid}{description} = $text;
1331: } elsif (($state[-2] eq "LINK") && ($state[-1] eq "TITLE")) {
1332: $$settings{$userid}{links}[$linknum]{title} = $text;
1333: } elsif (($state[-3] eq "LINK") && ($state[-2] eq "DESCRIPTION") && ($state[-1] eq "TEXT")) {
1334: $$settings{$userid}{links}[$linknum]{text} = $text;
1335: }
1336: }, "dtext"],
1337: end_h =>
1338: [sub {
1339: my ($tagname) = @_;
1.7 raeburn 1340: if ("@state" eq "USERS USER") {
1.2 raeburn 1341: $linknum = 0;
1342: }
1343: pop @state;
1344: }, "tagname"],
1345: );
1346: $p->unbroken_text(1);
1347: $p->parse_file($xmlfile);
1348: $p->eof;
1349:
1350: my $configvars = &LONCAPA::Configuration::read_conf('loncapa.conf');
1351: my $xmlstem = $$configvars{'lonDaemons'}."/tmp/".$user_cdom."_".$user_crs."_";
1352:
1353: foreach my $user_id (keys %{$settings}) {
1354: if ($$settings{$user_id}{user_role} eq "s") {
1355:
1356: } elsif ($user_handling eq 'enrollall') {
1357:
1358: }
1359: }
1360: }
1361:
1362: # ---------------------------------------------------------------- Process Blackboard groups
1363: sub process_group {
1364: my ($res,$docroot,$destdir,$settings) = @_;
1365: my $xmlfile = $docroot.'/'.$res.".dat";
1366: my $filecount = 0;
1367: my @state;
1368: my $grp;
1369:
1370: my $p = HTML::Parser->new
1371: (
1372: xml_mode => 1,
1373: start_h =>
1374: [sub {
1375: my ($tagname, $attr) = @_;
1376: push @state, $tagname;
1.7 raeburn 1377: if ("@state" eq "GROUPS GROUP") {
1.2 raeburn 1378: $grp = $attr->{id};
1379: }
1.7 raeburn 1380: if ("@state" eq "GROUPS GROUP TITLE") {
1.2 raeburn 1381: $$settings{$grp}{title} = $attr->{value};
1.7 raeburn 1382: } elsif ("@state" eq "GROUPS GROUP FLAGS ISAVAILABLE") {
1.2 raeburn 1383: $$settings{$grp}{isavailable} = $attr->{value};
1.7 raeburn 1384: } elsif ("@state" eq "GROUPS GROUP FLAGS HASCHATROOM") {
1.2 raeburn 1385: $$settings{$grp}{chat} = $attr->{value};
1386: } elsif ("@state" eq "GROUPS GROUP FLAGS HASDISCUSSIONBOARD") {
1387: $$settings{$grp}{discussion} = $attr->{value};
1388: } elsif ("@state" eq "GROUPS GROUP FLAGS HASTRANSFERAREA") {
1389: $$settings{$grp}{transfer} = $attr->{value};
1390: } elsif ("@state" eq "GROUPS GROUP FLAGS ISPUBLIC") {
1391: $$settings{$grp}{public} = $attr->{value};
1392: }
1393: }, "tagname, attr"],
1394: text_h =>
1395: [sub {
1396: my ($text) = @_;
1397: if ("@state" eq "GROUPS DESCRIPTION") {
1398: $$settings{$grp}{description} = $text;
1399: # print "Staff text is $text\n";
1400: }
1401: }, "dtext"],
1402: end_h =>
1403: [sub {
1404: my ($tagname) = @_;
1405: pop @state;
1406: }, "tagname"],
1407: );
1408: $p->unbroken_text(1);
1409: $p->parse_file($xmlfile);
1410: $p->eof;
1411: }
1412:
1413: # ---------------------------------------------------------------- Process Blackboard Staff
1414: sub process_staff {
1.33 raeburn 1415: my ($res,$docroot,$destdir,$settings,$resrcfiles) = @_;
1.2 raeburn 1416: my $xmlfile = $docroot.'/'.$res.".dat";
1417: my $filecount = 0;
1418: my @state;
1419: %{$$settings{name}} = ();
1.33 raeburn 1420: %{$$settings{office}} = ();
1.2 raeburn 1421:
1422: my $p = HTML::Parser->new
1423: (
1424: xml_mode => 1,
1425: start_h =>
1426: [sub {
1427: my ($tagname, $attr) = @_;
1428: push @state, $tagname;
1.7 raeburn 1429: if ("@state" eq "STAFFINFO TITLE") {
1.2 raeburn 1430: $$settings{title} = $attr->{value};
1.7 raeburn 1431: } elsif ("@state" eq "STAFFINFO BIOGRAPHY TEXTCOLOR") {
1.2 raeburn 1432: $$settings{textcolor} = $attr->{value};
1.7 raeburn 1433: } elsif ("@state" eq "STAFFINFO BIOGRAPHY FLAGS ISHTML") {
1.2 raeburn 1434: $$settings{ishtml} = $attr->{value};
1435: } elsif ("@state" eq "STAFFINFO FLAGS ISAVAILABLE" ) {
1436: $$settings{isavailable} = $attr->{value};
1437: } elsif ("@state" eq "STAFFINFO FLAGS ISFOLDER" ) {
1438: $$settings{isfolder} = $attr->{value};
1439: } elsif ("@state" eq "STAFFINFO POSITION" ) {
1440: $$settings{position} = $attr->{value};
1441: } elsif ("@state" eq "STAFFINFO HOMEPAGE" ) {
1442: $$settings{homepage} = $attr->{value};
1443: } elsif ("@state" eq "STAFFINFO IMAGE") {
1444: $$settings{image} = $attr->{value};
1445: }
1446: }, "tagname, attr"],
1447: text_h =>
1448: [sub {
1449: my ($text) = @_;
1450: if ("@state" eq "STAFFINFO BIOGRAPHY TEXT") {
1451: $$settings{text} = $text;
1452: # print "Staff text is $text\n";
1453: } elsif ("@state" eq "STAFFINFO CONTACT PHONE") {
1454: $$settings{phone} = $text;
1455: } elsif ("@state" eq "STAFFINFO CONTACT EMAIL") {
1456: $$settings{email} = $text;
1457: } elsif ("@state" eq "STAFFINFO CONTACT NAME FORMALTITLE") {
1458: $$settings{name}{formaltitle} = $text;
1459: } elsif ("@state" eq "STAFFINFO CONTACT NAME FAMILY") {
1460: $$settings{name}{family} = $text;
1461: } elsif ("@state" eq "STAFFINFO CONTACT NAME GIVEN") {
1462: $$settings{name}{given} = $text;
1463: } elsif ("@state" eq "STAFFINFO CONTACT OFFICE HOURS") {
1464: $$settings{office}{hours} = $text;
1465: } elsif ("@state" eq "STAFFINFO CONTACT OFFICE ADDRESS") {
1466: $$settings{office}{address} = $text;
1467: }
1468: }, "dtext"],
1469: end_h =>
1470: [sub {
1471: my ($tagname) = @_;
1472: pop @state;
1473: }, "tagname"],
1474: );
1475: $p->unbroken_text(1);
1476: $p->parse_file($xmlfile);
1477: $p->eof;
1478:
1479: my $fontcol = '';
1480: if (defined($$settings{textcolor})) {
1481: $fontcol = qq|color="$$settings{textcolor}"|;
1482: }
1483: if (defined($$settings{text})) {
1484: if ($$settings{ishtml} eq "true") {
1485: $$settings{text} = &HTML::Entities::decode($$settings{text});
1486: }
1487: }
1488: my $staffentry = qq|
1489: <table border="0" cellpadding="0" cellspacing="0" width="100%">
1490: <tr>
1491: <td colspan="2"><hr /><font face="arial,helv" size="3"><b>$$settings{name}{formaltitle} $$settings{name}{given} $$settings{name}{family}</b></font>
1492: </td>
1493: </tr>
1494: <tr>
1495: <td valign="top">
1496: <table width="100% border="0" cols="2" cellpadding="0" cellspacing="0">|;
1497: if ( defined($$settings{email}) && $$settings{email} ne '') {
1498: $staffentry .= qq|
1499: <tr>
1500: <td width="100" valign="top">
1501: <font face="arial" size="2"><b>Email:</b></font>
1502: </td>
1503: <td>
1504: <font face="arial" size="2"><a href="mailto:$$settings{email}">$$settings{email}</a></font>
1505: </td>
1506: </tr>
1507: |;
1508: }
1509: if (defined($$settings{phone}) && $$settings{phone} ne '') {
1510: $staffentry .= qq|
1511: <tr>
1512: <td width="100" valign="top">
1513: <font face="arial" size="2"><b>Phone:</b></font>
1514: </td>
1515: <td>
1516: <font face="arial" size="2">$$settings{phone}</font>
1517: </td>
1518: </tr>
1519: |;
1520: }
1521: if (defined($$settings{office}{address}) && $$settings{office}{address} ne '') {
1522: $staffentry .= qq|
1523: <tr>
1524: <td width="100" valign="top">
1525: <font face="arial" size="2"><b>Address:</b></font>
1526: </td>
1527: <td>
1528: <font face="arial" size="2">$$settings{office}{address}</font>
1529: </td>
1530: </tr>
1531: |;
1532: }
1533: if (defined($$settings{office}{hours}) && $$settings{office}{hours} ne '') {
1534: $staffentry .= qq|
1535: <tr>
1536: <td width="100" valign="top">
1537: <font face="arial" size="2"><b>Office Hours:</b></font>
1538: </td>
1539: <td>
1.46 bisitz 1540: <font face="arial" size="2">$$settings{office}{hours}</font>
1.2 raeburn 1541: </td>
1542: </tr>
1543: |;
1544: }
1545: if ( defined($$settings{homepage}) && $$settings{homepage} ne '') {
1546: $staffentry .= qq|
1547: <tr>
1548: <td width="100" valign="top">
1549: <font face="arial" size="2"><b>Personal Link:</b></font>
1550: </td>
1551: <td>
1552: <font face="arial" size="2"><a href="$$settings{homepage}">$$settings{homepage}</a></font>
1553: </td>
1554: </tr>
1555: |;
1556: }
1557: if (defined($$settings{text}) && $$settings{text} ne '') {
1558: $staffentry .= qq|
1559: <tr>
1560: <td colspan="2">
1561: <font face="arial" size="2" $fontcol><b>Other Information:</b><br/>$$settings{text}</font>
1562: </td>
1563: </tr>
1564: |;
1565: }
1566: $staffentry .= qq|
1567: </table>
1568: </td>
1569: <td align="right" valign="top">
1570: |;
1571: if ( defined($$settings{image}) ) {
1572: $staffentry .= qq|
1.33 raeburn 1573: <img src="$res/$$settings{image}">
1.2 raeburn 1574: |;
1575: }
1576: $staffentry .= qq|
1577: </td>
1578: </tr>
1579: </table>
1580: |;
1581: open(FILE,">$destdir/resfiles/$res.html");
1582: push @{$resrcfiles}, "$res.html";
1583: print FILE qq|<html>
1584: <head>
1585: <title>$$settings{title}</title>
1586: </head>
1587: <body bgcolor='#ffffff'>
1588: $staffentry
1589: </body>
1590: </html>|;
1591: close(FILE);
1592: }
1593:
1594: # ---------------------------------------------------------------- Process Blackboard Links
1595: sub process_link {
1.33 raeburn 1596: my ($res,$docroot,$destdir,$settings,$resrcfiles) = @_;
1.2 raeburn 1597: my $xmlfile = $docroot.'/'.$res.".dat";
1598: my @state = ();
1599: my $p = HTML::Parser->new
1600: (
1601: xml_mode => 1,
1602: start_h =>
1603: [sub {
1604: my ($tagname, $attr) = @_;
1605: push @state, $tagname;
1.7 raeburn 1606: if ("@state" eq "EXTERNALLINK TITLE") {
1.2 raeburn 1607: $$settings{title} = $attr->{value};
1.7 raeburn 1608: } elsif ("@state" eq "EXTERNALLINK TEXTCOLOR") {
1.2 raeburn 1609: $$settings{textcolor} = $attr->{value};
1.7 raeburn 1610: } elsif ("@state" eq "EXTERNALLINK DESCRIPTION FLAGS ISHTML") {
1.15 raeburn 1611: $$settings{ishtml} = $attr->{value};
1.2 raeburn 1612: } elsif ("@state" eq "EXTERNALLINK FLAGS ISAVAILABLE" ) {
1613: $$settings{isavailable} = $attr->{value};
1614: } elsif ("@state" eq "EXTERNALLINK FLAGS LAUNCHINNEWWINDOW" ) {
1615: $$settings{newwindow} = $attr->{value};
1616: } elsif ("@state" eq "EXTERNALLINK FLAGS ISFOLDER" ) {
1617: $$settings{isfolder} = $attr->{value};
1618: } elsif ("@state" eq "EXTERNALLINK POSITION" ) {
1619: $$settings{position} = $attr->{value};
1620: } elsif ("@state" eq "EXTERNALLINK URL" ) {
1.7 raeburn 1621: $$settings{url} = $attr->{value};
1.2 raeburn 1622: }
1623: }, "tagname, attr"],
1624: text_h =>
1625: [sub {
1626: my ($text) = @_;
1627: if ("@state" eq "EXTERNALLINK DESCRIPTION TEXT") {
1628: $$settings{text} = $text;
1629: }
1630: }, "dtext"],
1631: end_h =>
1632: [sub {
1633: my ($tagname) = @_;
1634: pop @state;
1635: }, "tagname"],
1636: );
1637: $p->unbroken_text(1);
1638: $p->parse_file($xmlfile);
1639: $p->eof;
1640:
1641: my $linktag = '';
1642: my $fontcol = '';
1643: if (defined($$settings{textcolor})) {
1644: $fontcol = qq|<font color="$$settings{textcolor}">|;
1645: }
1646: if (defined($$settings{text})) {
1647: if ($$settings{ishtml} eq "true") {
1648: $$settings{text} = &HTML::Entities::decode($$settings{text});
1649: }
1650: }
1651:
1652: if (defined($$settings{url}) ) {
1653: $linktag = qq|<a href="$$settings{url}"|;
1654: if ($$settings{newwindow} eq "true") {
1655: $linktag .= qq| target="launch"|;
1656: }
1657: $linktag .= qq|>$$settings{title}</a>|;
1658: }
1659:
1660: open(FILE,">$destdir/resfiles/$res.html");
1661: push @{$resrcfiles}, "$res.html";
1662: print FILE qq|<html>
1663: <head>
1664: <title>$$settings{title}</title>
1665: </head>
1666: <body bgcolor='#ffffff'>
1667: $fontcol
1668: $linktag
1669: $$settings{text}
1670: |;
1671: if (defined($$settings{textcolor})) {
1672: print FILE qq|</font>|;
1673: }
1674: print FILE qq|
1675: </body>
1676: </html>|;
1677: close(FILE);
1678: }
1679:
1680: # ---------------------------------------------------------------- Process Blackboard Discussion Boards
1681: sub process_db {
1682: my ($res,$docroot,$destdir,$timestamp,$crs,$cdom,$handling,$uname,$settings,$longcrs) = @_;
1683: my $xmlfile = $docroot.'/'.$res.".dat";
1684: my @state = ();
1685: my @allmsgs = ();
1686: my %msgidx = ();
1687: my %threads; # all threads, keyed by message ID
1688: my $msg_id; # the current message ID
1689: my %message; # the current message being accumulated for $msg_id
1690:
1691: my $p = HTML::Parser->new
1692: (
1693: xml_mode => 1,
1694: start_h =>
1695: [sub {
1696: my ($tagname, $attr) = @_;
1697: push @state, $tagname;
1698: my $depth = 0;
1699: my @seq = ();
1700: if ("@state" eq "FORUM TITLE") {
1701: $$settings{title} = $attr->{value};
1702: } elsif ("@state" eq "FORUM DESCRIPTION TEXTCOLOR") {
1703: $$settings{textcolor} = $attr->{value};
1704: } elsif ("@state" eq "FORUM DESCRIPTION FLAGS ISHTML") {
1705: $$settings{ishtml} = $attr->{value};
1706: } elsif ("@state" eq "FORUM DESCRIPTION FLAGS ISNEWLINELITERAL") {
1707: $$settings{newline} = $attr->{value};
1708: } elsif ("@state" eq "FORUM POSITION" ) {
1709: $$settings{position} = $attr->{value};
1710: } elsif ("@state" eq "FORUM FLAGS ISREADONLY") {
1711: $$settings{isreadonly} = $attr->{value};
1712: } elsif ("@state" eq "FORUM FLAGS ISAVAILABLE" ) {
1713: $$settings{isavailable} = $attr->{value};
1714: } elsif ("@state" eq "FORUM FLAGS ALLOWANONYMOUSPOSTINGS" ) {
1715: $$settings{allowanon} = $attr->{value};
1716: } elsif ( ($state[0] eq "FORUM") && ($state[1] eq "MESSAGETHREADS") && ($state[2] eq "MSG") ) {
1717: if ($state[-1] eq "MSG") {
1718: unless ($msg_id eq '') {
1719: push @{$threads{$msg_id}}, { %message };
1720: $depth = @state - 3;
1721: if ($depth > @seq) {
1722: push @seq, $msg_id;
1723: }
1724: }
1725: if ($depth < @seq) {
1726: pop @seq;
1727: }
1728: $msg_id = $attr->{id};
1729: push @allmsgs, $msg_id;
1730: $msgidx{$msg_id} = @allmsgs;
1731: %message = ();
1732: $message{depth} = $depth;
1733: if ($depth > 0) {
1734: $message{parent} = $seq[-1];
1735: } else {
1736: $message{parent} = "None";
1737: }
1738: } elsif ($state[-1] eq "TITLE") {
1739: $message{title} = $attr->{value};
1740: } elsif ( ( $state[-3] eq "MESSAGETEXT" ) && ( $state[-2] eq "FLAGS" ) && ( $state[-1] eq "ISHTML" ) ) {
1741: $message{ishtml} = $attr->{value};
1742: } elsif ( ( $state[-3] eq "MESSAGETEXT" ) && ( $state[-2] eq "FLAGS" ) && ( $state[-1] eq "ISNEWLINELITERAL" ) ) {
1743: $message{newline} = $attr->{value};
1744: } elsif ( ( $state[-2] eq "DATES" ) && ( $state[-1] eq "CREATED" ) ) {
1745: $message{created} = $attr->{value};
1746: } elsif ( $state[@state-2] eq "FLAGS") {
1747: if ($state[@state-1] eq "ISANONYMOUS") {
1748: $message{isanonymous} = $attr->{value};
1749: }
1750: } elsif ( $state[-2] eq "USER" ) {
1751: if ($state[-1] eq "USERID") {
1752: $message{userid} = $attr->{value};
1753: } elsif ($state[@state-1] eq "USERNAME") {
1754: $message{username} = $attr->{value};
1755: } elsif ($state[@state-1] eq "EMAIL") {
1756: $message{email} = $attr->{value};
1757: }
1758: } elsif ( ($state[-2] eq "FILELIST") && ($state[-1] eq "IMAGE") ) {
1759: $message{attachment} = $attr->{value};
1760: }
1761: }
1762: }, "tagname, attr"],
1763: text_h =>
1764: [sub {
1765: my ($text) = @_;
1766: if ("@state" eq "FORUM DESCRIPTION TEXT") {
1767: $$settings{text} = $text;
1768: } elsif ( ($state[0] eq "FORUM") && ($state[1] eq "MESSAGETHREADS") && ($state[2] eq "MSG") ) {
1769: if ( ($state[-2] eq "MESSAGETEXT") && ($state[-1] eq "TEXT") ){
1770: $message{text} = $text;
1771: }
1772: }
1773: }, "dtext"],
1774: end_h =>
1775: [sub {
1776: my ($tagname) = @_;
1777: if ( $state[-1] eq "MESSAGETHREADS" ) {
1778: push @{$threads{$msg_id}}, { %message };
1779: }
1780: pop @state;
1781: }, "tagname"],
1782: );
1783: $p->unbroken_text(1);
1784: $p->parse_file($xmlfile);
1785: $p->eof;
1786:
1787: if (defined($$settings{text})) {
1788: if ($$settings{ishtml} eq "false") {
1789: if ($$settings{isnewline} eq "true") {
1790: $$settings{text} =~ s#\n#<br/>#g;
1791: }
1792: } else {
1793: $$settings{text} = &HTML::Entities::decode($$settings{text});
1794: }
1795: if (defined($$settings{fontcolor}) ) {
1796: $$settings{text} = "<font color=\"".$$settings{textcolor}."\">".$$settings{text}."</font>";
1797: }
1798: }
1799: my $boardname = 'bulletinpage_'.$timestamp;
1800: my %boardinfo = (
1801: 'aaa_title' => $$settings{title},
1802: 'bbb_content' => $$settings{text},
1803: 'ccc_webreferences' => '',
1804: 'uploaded.lastmodified' => time,
1805: );
1806:
1807: my $putresult = &Apache::lonnet::put($boardname,\%boardinfo,$cdom,$crs);
1808: if ($handling eq 'importall') {
1809: foreach my $msg_id (@allmsgs) {
1810: foreach my $message ( @{$threads{$msg_id}} ) {
1811: my %contrib = (
1812: 'sendername' => $$message{userid},
1813: 'senderdomain' => $cdom,
1814: 'screenname' => '',
1815: 'plainname' => $$message{username},
1816: );
1817: unless ($$message{parent} eq 'None') {
1818: $contrib{replyto} = $msgidx{$$message{parent}};
1819: }
1820: if (defined($$message{isanonymous}) ) {
1821: if ($$message{isanonymous} eq 'true') {
1822: $contrib{'anonymous'} = 'true';
1823: }
1824: }
1825: if ( defined($$message{attachment}) ) {
1826: my $url = $$message{attachment};
1827: my $oldurl = $url;
1828: my $newurl = $url;
1829: unless ($url eq '') {
1830: $newurl =~ s/\//_/g;
1831: unless ($longcrs eq '') {
1832: if (!-e "/home/httpd/lonUsers/$cdom/$longcrs/userfiles") {
1833: mkdir("/home/httpd/lonUsers/$cdom/$longcrs/userfiles",0755);
1834: }
1835: if (!-e "/home/httpd/lonUsers/$cdom/$longcrs/userfiles/$newurl") {
1836: system("cp $destdir/resfiles/$res/$$message{attachment} /home/httpd/lonUsers/$cdom/$longcrs/userfiles/$newurl");
1837: }
1838: $contrib{attachmenturl} = '/uploaded/'.$cdom.'/'.$crs.'/'.$newurl;
1839: }
1840: }
1841: }
1842: if (defined($$message{title}) ) {
1843: $contrib{'message'} = $$message{title};
1844: }
1845: if (defined($$message{text})) {
1846: if ($$message{ishtml} eq "false") {
1847: if ($$message{isnewline} eq "true") {
1848: $$message{text} =~ s#\n#<br/>#g;
1849: }
1850: } else {
1851: $$message{text} = &HTML::Entities::decode($$message{text});
1852: }
1853: $contrib{'message'} .= '<br /><br />'.$$message{text};
1854: my $symb = 'bulletin___'.$timestamp.'___adm/wrapper/adm/'.$cdom.'/'.$uname.'/'.$timestamp.'/bulletinboard';
1855: my $postresult = &addposting($symb,\%contrib,$cdom,$crs);
1856: }
1857: }
1858: }
1859: }
1860: }
1861:
1.47 bisitz 1862: # ---------------------------------------------------------------- Add Posting to Discussion Board
1.2 raeburn 1863: sub addposting {
1864: my ($symb,$contrib,$cdom,$crs)=@_;
1865: my $status='';
1866: if (($symb) && ($$contrib{message})) {
1867: my $crsdom = $cdom.'_'.$crs;
1868: &Apache::lonnet::store($contrib,$symb,$crsdom,$cdom,$crs);
1869: my %storenewentry=($symb => time);
1870: &Apache::lonnet::put('discussiontimes',\%storenewentry,$cdom,$crs);
1871: }
1872: my %record=&Apache::lonnet::restore('_discussion');
1873: my ($temp)=keys %record;
1874: unless ($temp=~/^error\:/) {
1875: my %newrecord=();
1876: $newrecord{'resource'}=$symb;
1877: $newrecord{'subnumber'}=$record{'subnumber'}+1;
1878: &Apache::lonnet::cstore(\%newrecord,'_discussion');
1879: $status = 'ok';
1880: } else {
1881: $status.='Failed.';
1882: }
1883: return $status;
1884: }
1.15 raeburn 1885:
1886: sub parse_bb5_assessment {
1887: my ($res,$docroot,$container,$settings,$allanswers,$allchoices,$allids) = @_;
1.2 raeburn 1888: my $xmlfile = $docroot.'/'.$res.".dat";
1889: my @state = ();
1890: my $id; # the current question ID
1891: my $answer_id; # the current answer ID
1892: my %toptag = ( pool => 'POOL',
1893: quiz => 'ASSESSMENT',
1894: survey => 'ASSESSMENT'
1895: );
1896:
1897: my $p = HTML::Parser->new
1898: (
1899: xml_mode => 1,
1900: start_h =>
1901: [sub {
1902: my ($tagname, $attr) = @_;
1903: push @state, $tagname;
1904: my $depth = 0;
1905: my @seq = ();
1906: my $class;
1907: my $state_str = join(" ",@state);
1908: if ($container eq "pool") {
1909: if ("@state" eq "POOL TITLE") {
1910: $$settings{title} = $attr->{value};
1911: }
1912: } else {
1913: if ("@state" eq "ASSESSMENT TITLE") {
1914: $$settings{title} = $attr->{value};
1915: } elsif ("@state" eq "ASSESSMENT FLAG" ) {
1916: $$settings{isnewline} = $attr->{value};
1917: } elsif ("@state" eq "ASSESSMENT FLAGS ISAVAILABLE") {
1918: $$settings{isavailable} = $attr->{value};
1919: } elsif ("@state" eq "ASSESSMENT FLAGS ISANONYMOUS" ) {
1920: $$settings{isanonymous} = $attr->{id};
1921: } elsif ("@state" eq "ASSESSMENT FLAGS GIVE FEEDBACK" ) {
1922: $$settings{feedback} = $attr->{id};
1923: } elsif ("@state" eq "ASSESSMENT FLAGS SHOWCORRECT" ) {
1924: $$settings{showcorrect} = $attr->{id};
1925: } elsif ("@state" eq "ASSESSMENT FLAGS SHOWRESULTS" ) {
1926: $$settings{showresults} = $attr->{id};
1927: } elsif ("@state" eq "ASSESSMENT FLAGS ALLOWMULTIPLE" ) {
1928: $$settings{allowmultiple} = $attr->{id};
1929: } elsif ("@state" eq "ASSESSMENT ASSESSMENTTYPE" ) {
1930: $$settings{type} = $attr->{id};
1931: }
1932: }
1933: if ("@state" eq "$toptag{$container} QUESTIONLIST QUESTION") {
1934: $id = $attr->{id};
1.15 raeburn 1935: push @{$allids}, $id;
1.2 raeburn 1936: %{$$settings{$id}} = ();
1.15 raeburn 1937: @{$$allanswers{$id}} = ();
1.2 raeburn 1938: $$settings{$id}{class} = $attr->{class};
1939: unless ($container eq "pool") {
1940: $$settings{$id}{points} = $attr->{points};
1941: }
1942: @{$$settings{$id}{correctanswer}} = ();
1943: } elsif ( ($state[0] eq $toptag{$container}) && ($state[-1] =~ m/^QUESTION_(\w+)$/) ) {
1944: $id = $attr->{id};
1945: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "BODY") && ($state[3] eq "FLAGS") ) {
1946: if ($state[4] eq "ISHTML") {
1.20 raeburn 1947: $$settings{$id}{ishtml} = $attr->{value};
1.2 raeburn 1948: } elsif ($state[4] eq "ISNEWLINELITERAL") {
1949: $$settings{$id}{newline} = $attr->{value};
1950: }
1951: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "IMAGE") ) {
1952: $$settings{$id}{image} = $attr->{value};
1953: $$settings{$id}{style} = $attr->{style};
1954: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "URL") ) {
1955: $$settings{$id}{url} = $attr->{value};
1956: $$settings{$id}{name} = $attr->{name};
1957: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[-1] eq "ANSWER") ) {
1958: $answer_id = $attr->{id};
1.15 raeburn 1959: push @{$$allanswers{$id}},$answer_id;
1.2 raeburn 1960: %{$$settings{$id}{$answer_id}} = ();
1961: $$settings{$id}{$answer_id}{position} = $attr->{position};
1962: if ($$settings{$id}{class} eq 'QUESTION_MATCH') {
1963: $$settings{$id}{$answer_id}{placement} = $attr->{placement};
1964: $$settings{$id}{$answer_id}{type} = 'answer';
1965: }
1966: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[-1] eq "CHOICE") ) {
1967: $answer_id = $attr->{id};
1.15 raeburn 1968: push @{$$allchoices{$id}},$answer_id;
1.2 raeburn 1969: %{$$settings{$id}{$answer_id}} = ();
1970: $$settings{$id}{$answer_id}{position} = $attr->{position};
1971: $$settings{$id}{$answer_id}{placement} = $attr->{placement};
1972: $$settings{$id}{$answer_id}{type} = 'choice';
1973: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "ANSWER") ) {
1974: if ($state[3] eq "IMAGE") {
1975: $$settings{$id}{$answer_id}{image} = $attr->{value};
1976: $$settings{$id}{$answer_id}{style} = $attr->{style};
1977: } elsif ($state[3] eq "URL") {
1978: $$settings{$id}{$answer_id}{url} = $attr->{value};
1979: }
1980: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "CHOICE") ) {
1981: if ($state[3] eq "IMAGE") {
1982: $$settings{$id}{$answer_id}{image} = $attr->{value};
1983: $$settings{$id}{$answer_id}{style} = $attr->{style};
1984: } elsif ($state[3] eq "URL") {
1985: $$settings{$id}{$answer_id}{url} = $attr->{value};
1986: }
1987: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "GRADABLE") && ($state[3] eq "CORRECTANSWER") ) {
1988: my $corr_answer = $attr->{answer_id};
1989: push @{$$settings{$id}{correctanswer}}, $corr_answer;
1990: my $type = $1;
1991: if ($type eq 'TRUEFALSE') {
1992: $$settings{$id}{$corr_answer}{answer_position} = $attr->{position};
1993: } elsif ($type eq 'ORDER') {
1994: $$settings{$id}{$corr_answer}{order} = $attr->{order};
1995: } elsif ($type eq 'MATCH') {
1996: $$settings{$id}{$corr_answer}{choice_id} = $attr->{choice_id};
1997: }
1998: }
1999: }, "tagname, attr"],
2000: text_h =>
2001: [sub {
2002: my ($text) = @_;
1.16 raeburn 2003: $text =~ s/^\s+//g;
2004: $text =~ s/\s+$//g;
1.2 raeburn 2005: unless ($container eq "pool") {
2006: if ("@state" eq "ASSESSMENT DESCRIPTION TEXT") {
2007: $$settings{description} = $text;
2008: } elsif ("@state" eq "ASSESSMENT INSTRUCTIONS ") {
2009: $$settings{instructions}{text} = $text;
2010: }
2011: }
1.16 raeburn 2012: if ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "BODY") && ($state[-1] eq "TEXT") ) {
2013: unless ($text eq '') {
2014: $$settings{$id}{text} = $text;
2015: }
2016: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "ANSWER") && ($state[-1] eq "TEXT") ) {
2017: unless ($text eq '') {
2018: $$settings{$id}{$answer_id}{text} = $text;
2019: }
2020: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "CHOICE") && ($state[-1] eq "TEXT") ) {
2021: unless ($text eq '') {
2022: $$settings{$id}{$answer_id}{text} = $text;
2023: }
2024: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "GRADABLE") && ($state[-1] eq "FEEDBACK_WHEN_CORRECT") ) {
2025: unless ($text eq '') {
2026: $$settings{$id}{feedback_corr} = $text;
2027: }
2028: } elsif ( ($state[0] eq $toptag{$container}) && ($state[1] =~ m/^QUESTION_(\w+)$/) && ($state[2] eq "GRADABLE") && ($state[-1] eq "FEEDBACK_WHEN_INCORRECT") ) {
2029: unless ($text eq '') {
2030: $$settings{$id}{feedback_incorr} = $text;
2031: }
1.2 raeburn 2032: }
2033: }, "dtext"],
2034: end_h =>
2035: [sub {
2036: my ($tagname) = @_;
2037: pop @state;
2038: }, "tagname"],
2039: );
2040: $p->unbroken_text(1);
1.16 raeburn 2041: $p->marked_sections(1);
1.2 raeburn 2042: $p->parse_file($xmlfile);
2043: $p->eof;
1.15 raeburn 2044: }
2045:
2046: sub parse_bb6_assessment {
1.30 raeburn 2047: my ($res,$docroot,$container,$settings,$allids) = @_;
1.28 raeburn 2048: my $xmlfile = $docroot.'/'.$res.".dat";
2049: my @state = ();
2050: my $id; # the current question ID
1.29 raeburn 2051: my $response; # the current response ID
1.30 raeburn 2052: my $foil; # the current foil ID
2053: my $numchoice; # the current right match choice;
2054: my $labelcount; # the current count of choices for a matching item.
1.28 raeburn 2055: my $curr_shuffle;
1.30 raeburn 2056: my $curr_class; # the current question type
1.29 raeburn 2057: my $curr_matchitem;
1.30 raeburn 2058: my $curr_block_type; # the current block type
2059: my $curr_flow; # the current flow class attribute
2060: my $curr_flow_mat; # the current flow_mat class attribute
2061: my $curr_feedback_type; # the current feedback type
2062: my $numorder; # counter for ordering type questions
2063:
2064: my $itemfrag = "questestinterop assessment section item";
2065: my $presfrag = "$itemfrag presentation flow flow";
2066: my $blockflow = 'flow';
2067: my $responselid;
2068: my $instructionfrag = "questestinterop assessment presentation_material flow_mat material";
2069: my $feedbackfrag = "$itemfrag itemfeedback";
2070: my $feedback_tag = '';
2071: my $responselid;
1.28 raeburn 2072: my $p = HTML::Parser->new
2073: (
2074: xml_mode => 1,
2075: start_h =>
2076: [sub {
2077: my ($tagname, $attr) = @_;
2078: push @state, $tagname;
2079: if ("@state" eq "questestinterop assessment") {
2080: $$settings{title} = $attr->{title};
2081: }
1.29 raeburn 2082: if ("@state" eq "questestinterop assessment rubric flow_mat material mat_extension mat_formattedtext") {
1.30 raeburn 2083: $$settings{description}{texttype} = $attr->{type};
1.29 raeburn 2084: }
1.30 raeburn 2085: if ("@state" eq $presfrag) {
2086: if ($attr->{class} eq 'QUESTION_BLOCK') {
2087: $curr_block_type = 'question';
2088: } elsif ($attr->{class} eq 'RESPONSE_BLOCK') {
1.29 raeburn 2089: $curr_block_type = 'response';
1.30 raeburn 2090: if ($curr_class eq 'Matching') {
2091: $responselid = 'flow response_lid';
2092: } else {
2093: $responselid = 'response_lid';
2094: }
2095: } elsif (($attr->{class} eq 'RIGHT_MATCH_BLOCK')) {
2096: $numchoice = 0;
1.29 raeburn 2097: $curr_block_type = 'rightmatch';
1.30 raeburn 2098: }
1.29 raeburn 2099: }
1.30 raeburn 2100: if ("@state" eq "$presfrag flow") {
2101: if (($curr_block_type =~ /^rightmatch/) && ($attr->{class} eq 'Block')) {
2102: $curr_block_type = 'rightmatch'.$numchoice;
2103: $numchoice ++;
1.29 raeburn 2104: }
1.28 raeburn 2105: }
1.30 raeburn 2106: if ($state[-1] eq 'flow') {
2107: $curr_flow = $attr->{class};
1.28 raeburn 2108: }
1.30 raeburn 2109: if ($state[-1] eq 'flow_mat') {
2110: $curr_flow_mat = $attr->{class};
2111: }
2112: if ("@state" eq "$presfrag $blockflow material mat_extension mat_formattedtext") {
1.29 raeburn 2113: $$settings{$id}{$curr_block_type}{texttype} = $attr->{texttype};
1.28 raeburn 2114: }
1.30 raeburn 2115: if ("@state" eq "$presfrag $blockflow material matapplication") {
1.29 raeburn 2116: $$settings{$id}{$curr_block_type}{image} = $attr->{uri};
2117: $$settings{$id}{$curr_block_type}{style} = $attr->{embedded};
2118: $$settings{$id}{$curr_block_type}{label} = $attr->{label};
1.28 raeburn 2119: }
1.30 raeburn 2120: if ("@state" eq "$presfrag $blockflow material mattext") {
1.29 raeburn 2121: $$settings{$id}{$curr_block_type}{link} = $attr->{uri};
1.28 raeburn 2122: }
1.30 raeburn 2123: if ("@state" eq "$presfrag $responselid") {
2124: $response = $attr->{ident};
2125: $labelcount = 0;
1.29 raeburn 2126: if ($curr_class eq 'Matching') {
1.30 raeburn 2127: push(@{$$settings{$id}{answers}},$response);
1.29 raeburn 2128: %{$$settings{$id}{$response}} = ();
2129: foreach my $key (keys(%{$$settings{$id}{$curr_block_type}})) {
2130: $$settings{$id}{$response}{$key} = $$settings{$id}{$curr_block_type}{$key};
2131: }
2132: %{$$settings{$id}{$curr_block_type}} = ();
2133: }
2134: }
1.30 raeburn 2135: if ("@state" eq "$presfrag $responselid render_choice") {
2136: $curr_shuffle = $attr->{shuffle};
2137: }
2138: if ("@state" eq "$presfrag $responselid render_choice flow_label response_label") {
2139: $foil = $attr->{ident};
2140: %{$$settings{$id}{$foil}} = ();
2141: $$settings{$id}{$foil}{randomize} = $curr_shuffle;
2142: unless ($curr_class eq 'Essay'){
2143: if ($curr_class eq 'Matching') {
2144: push(@{$$settings{$id}{$response}{items}},$foil);
2145: $$settings{$id}{$foil}{order} = $labelcount;
2146: $labelcount ++;
2147: } else {
2148: push(@{$$settings{$id}{answers}},$foil);
2149: @{$$settings{$id}{correctanswer}} = ();
2150: }
2151: }
2152: }
2153: if ("@state" eq "$presfrag $responselid render_choice flow_label response_label flow_mat material matapplication") {
2154: $$settings{$id}{$foil}{filetype} = $attr->{embedded};
2155: $$settings{$id}{$foil}{label} = $attr->{label};
2156: $$settings{$id}{$foil}{uri} = $attr->{uri};
2157: }
2158: if ("@state" eq "$presfrag $responselid render_choice flow_label response_label flow_mat material mattext") {
2159: $$settings{$id}{$foil}{link} = $attr->{uri};
1.29 raeburn 2160: }
1.30 raeburn 2161: if ("@state" eq "questestinterop assessment section item resprocessing") {
2162: if ($curr_class eq 'Matching') {
2163: $$settings{$id}{allchoices} = $numchoice;
2164: }
1.29 raeburn 2165: }
1.30 raeburn 2166: if ("@state" eq "questestinterop assessment section item resprocessing respcondition conditionvar varequal") {
1.29 raeburn 2167: if ($curr_class eq 'Matching') {
2168: $curr_matchitem = $attr->{respident};
1.28 raeburn 2169: }
2170: }
1.30 raeburn 2171: if ("@state" eq $feedbackfrag) {
1.28 raeburn 2172: $curr_feedback_type = $attr->{ident};
1.30 raeburn 2173: $feedback_tag = "";
2174: }
2175: if ("@state" eq "$feedbackfrag solution") {
2176: $curr_feedback_type = 'solution';
2177: $feedback_tag = "solution solutionmaterial";
1.28 raeburn 2178: }
1.30 raeburn 2179: if ("@state" eq "$feedbackfrag $feedback_tag flow_mat flow_mat material matapplication") {
1.28 raeburn 2180: $$settings{$id}{$curr_feedback_type.'feedback'}{filetype} = $attr->{'embedded'};
2181: $$settings{$id}{$curr_feedback_type.'feedback'}{label} = $attr->{label};
1.30 raeburn 2182: $$settings{$id}{$curr_feedback_type.'feedback'}{uri} = $attr->{uri};
1.28 raeburn 2183: }
1.30 raeburn 2184: if ("@state" eq "$feedbackfrag $feedback_tag flow_mat flow_mat material mattext") {
1.28 raeburn 2185: $$settings{$id}{$curr_feedback_type.'feedback'}{link} = $attr->{uri};
2186: }
2187: }, "tagname, attr"],
2188: text_h =>
2189: [sub {
2190: my ($text) = @_;
2191: $text =~ s/^\s+//g;
2192: $text =~ s/\s+$//g;
2193: if ("@state" eq "questestinterop assessment rubric flow_mat material mat_extension mat_formattedtext") {
1.30 raeburn 2194: $$settings{description}{text} = $text;
2195: }
2196: if ("@state" eq "questestinterop assessment rubric flow_mat material mattext") {
2197: $$settings{description}{text} = $text;
2198: }
2199: if ("@state" eq "$instructionfrag mat_extension mat_formattedtext") {
2200: $$settings{instructions}{text} = $text;
2201: }
2202: if ("@state" eq "$instructionfrag mattext") {
1.28 raeburn 2203: $$settings{instructions}{text} = $text;
2204: }
2205: if ("@state" eq "questestinterop assessment section item itemmetadata bbmd_asi_object_id") {
2206: $id = $text;
2207: push @{$allids}, $id;
2208: %{$$settings{$id}} = ();
1.30 raeburn 2209: @{$$settings{$id}{answers}} = ();
1.29 raeburn 2210: %{$$settings{$id}{question}} = ();
1.28 raeburn 2211: %{$$settings{$id}{correctfeedback}} = ();
2212: %{$$settings{$id}{incorrectfeedback}} = ();
1.29 raeburn 2213: %{$$settings{$id}{solutionfeedback}} = ();
1.28 raeburn 2214: }
2215: if ("@state" eq "questestinterop assessment section item itemmetadata bbmd_questiontype") {
2216: $$settings{$id}{class} = $text;
1.29 raeburn 2217: $curr_class = $text;
1.30 raeburn 2218: if ($curr_class eq 'Matching') {
2219: $blockflow = 'flow flow';
2220: } else {
2221: $blockflow = 'flow';
2222: }
1.28 raeburn 2223: }
1.30 raeburn 2224: if ("@state" eq "$presfrag $blockflow material mat_extension mat_formattedtext") {
1.29 raeburn 2225: $$settings{$id}{$curr_block_type}{text} = $text;
1.28 raeburn 2226: }
1.30 raeburn 2227: if ("@state" eq "$presfrag $blockflow material mattext") {
2228: if ($curr_flow eq 'LINK_BLOCK') {
2229: $$settings{$id}{$curr_block_type}{linkname} = $text;
2230: } elsif ($curr_flow eq 'FORMATTED_TEXT_BLOCK') {
2231: $$settings{$id}{$curr_block_type}{text} = $text;
2232: }
1.28 raeburn 2233: }
1.30 raeburn 2234: if ("@state" eq "$presfrag $responselid render_choice flow_label response_label flow_mat material mat_extension mat_formattedtext") {
2235: $$settings{$id}{$foil}{text} = $text;
2236: }
2237: if ("@state" eq "$presfrag $responselid render_choice flow_label response_label flow_mat material mattext") {
2238: if ($curr_flow_mat eq 'LINK_BLOCK') {
2239: $$settings{$id}{$foil}{linkname} = $text;
2240: } else {
2241: $$settings{$id}{$foil}{text} = $text;
2242: }
1.28 raeburn 2243: }
1.30 raeburn 2244: if ("@state" eq "questestinterop assessment section item resprocessing respcondition conditionvar varequal") {
2245: if ($curr_class eq 'Matching') {
1.29 raeburn 2246: $$settings{$id}{$curr_matchitem}{correctanswer} = $text;
1.30 raeburn 2247: } else {
2248: push(@{$$settings{$id}{correctanswer}},$text);
1.28 raeburn 2249: }
2250: }
1.30 raeburn 2251: if ("@state" eq "questestinterop assessment section item resprocessing respcondition conditionvar") {
2252: $numorder = 0;
1.29 raeburn 2253: }
1.30 raeburn 2254: if ("@state" eq "questestinterop assessment section item resprocessing respcondition conditionvar and varequal") {
2255: push(@{$$settings{$id}{correctanswer}},$text);
2256: if ($curr_class eq 'Ordering') {
2257: $numorder ++;
2258: $$settings{$id}{$text}{order} = $numorder;
2259: }
2260: }
2261: if ("@state" eq "$feedbackfrag $feedback_tag flow_mat flow_mat material mat_extension mat_formattedtext") {
1.28 raeburn 2262: $$settings{$id}{$curr_feedback_type.'feedback'}{text} = $text;
2263: }
1.30 raeburn 2264: if ("@state" eq "$feedbackfrag $feedback_tag flow_mat flow_mat material mattext") {
1.28 raeburn 2265: $$settings{$id}{$curr_feedback_type.'feedback'}{linkname} = $text;
2266: }
2267: }, "dtext"],
2268: end_h =>
2269: [sub {
2270: my ($tagname) = @_;
2271: pop @state;
2272: }, "tagname"],
2273: );
2274: $p->unbroken_text(1);
2275: $p->marked_sections(1);
2276: $p->parse_file($xmlfile);
2277: $p->eof;
2278: return;
1.15 raeburn 2279: }
2280:
1.35 raeburn 2281: sub parse_webctvista4_assessment {
2282: my ($res,$docroot,$href,$allids,$qzparams) = @_;
2283: my $xmlfile = $docroot.'/'.$href; #assessment file
2284: my @state = ();
2285: my $id; # the current question ID
2286: my $fieldlabel; # the current qti metadata field label
2287: my $outcome_id; # the current question ID for outcomes conditions
2288: my $pname; # the current outcomes parameter name
2289: my $numids = 0;
2290: %{$$qzparams{$res}} = ();
2291: %{$$qzparams{$res}{weight}} = ();
2292:
2293: my $p = HTML::Parser->new
2294: (
2295: xml_mode => 1,
2296: start_h =>
2297: [sub {
2298: my ($tagname, $attr) = @_;
2299: push @state, $tagname;
2300: my @seq = ();
1.40 raeburn 2301: if ("@state" eq "questestinterop assessment") {
2302: $$qzparams{$res}{id} = $attr->{'ident'};
2303: $$qzparams{$res}{title} = $attr->{'title'};
2304: }
1.35 raeburn 2305: if ("@state" eq "questestinterop assessment section itemref") {
2306: $id = $attr->{linkrefid};
2307: push(@{$allids},$id);
2308: $numids ++;
2309: }
2310: if ("@state" eq "questestinterop assessment section selection_ordering order") {
2311: $$qzparams{$res}{order_type} = $attr->{order_type};
2312: }
2313: }, "tagname, attr"],
2314: text_h =>
2315: [sub {
2316: my ($text) = @_;
2317: if ("@state" eq "questestinterop assessment qtimetadata qtimetadatafield fieldlabel") {
2318: $fieldlabel = $text;
2319: }
2320: if ("@state" eq "questestinterop assessment qtimetadata qtimetadatafield fieldentry") {
2321: $$qzparams{$res}{$fieldlabel} = $text;
2322: }
2323: if ("@state" eq "questestinterop assessment section outcomes_processing objects_condition outcomes_metadata") {
2324: $outcome_id = $text;
2325: }
2326: if ("@state" eq "questestinterop assessment section outcomes_processing objects_condition objects_parameter") {
2327: if ($pname eq 'qmd_weighting') {
2328: $$qzparams{$res}{weight}{$outcome_id} = $text;
2329: }
2330: }
2331: if ("@state" eq "questestinterop assessment section selection_ordering selection selection_number") {
2332: $$qzparams{$res}{numpick} = $text;
2333: }
2334: }, "dtext"],
2335: end_h =>
2336: [sub {
2337: my ($tagname) = @_;
2338: pop @state;
2339: }, "tagname"],
2340: );
2341: $p->unbroken_text(1);
2342: $p->parse_file($xmlfile);
2343: $p->eof;
2344: unless(defined($$qzparams{$res}{numpick})) {
2345: $$qzparams{$res}{numpick} = $numids;
2346: }
2347: }
2348:
2349: sub parse_webctvista4_question {
2350: my ($res,$docroot,$resources,$hrefs,$settings,$allquestids,$allanswers,$allchoices,$parent,$catinfo) = @_;
2351: my $xmlfile = $docroot.'/'.$$resources{$res}{file};
2352: my %classtypes = (
2353: WCT_Calculated => 'numerical',
2354: WCT_TrueFalse => 'multiplechoice',
2355: WCT_ShortAnswer => 'shortanswer',
2356: WCT_Paragraph => 'paragraph',
2357: WCT_MultipleChoice => 'multiplechoice',
2358: WCT_Matching => 'match',
2359: WCT_JumbledSentence => 'jumbled',
2360: WCT_FillInTheBlank => 'string',
2361: WCT_Combination => 'combination'
2362: );
2363: my @state = ();
2364: my $fieldlabel;
2365: my %questiondata;
2366: my $id; # the current question ID
2367: my $list; # the current list ID for multiple choice questions
2368: my $numid; # the current answer ID for numerical questions
2369: my $grp; # the current group ID for matching questions
2370: my $label; # the current reponse label for string questions
2371: my $str_id; # the current string ID for string questions
2372: my $unitid; # the current unit ID for numerical questions
2373: my $answer_id; # the current answer ID
2374: my $fdbk; # the current feedback ID
2375: my $currvar; # the current variable for numerical problems
2376: my $fibtype; # the current fill-in-blank type for numerical or string
2377: my $prompt;
2378: my $rows;
2379: my $columns;
2380: my $maxchars;
2381: my %setvar = (
2382: varname => '',
2383: action => '',
2384: );
2385: my $currtexttype;
2386: my $jumble_item;
2387: my $numbox = 0;
2388: my %str_answers = ();
2389: my $textlabel;
2390: my $currindex;
2391: my %varinfo = ();
2392: my $formula;
1.37 raeburn 2393: my $jumbnum = 0;
1.35 raeburn 2394: my $p = HTML::Parser->new
2395: (
2396: xml_mode => 1,
2397: start_h =>
2398: [sub {
2399: my ($tagname, $attr) = @_;
2400: push @state, $tagname;
2401: if ("@state" eq "questestinterop item") {
2402: $id = $attr->{ident};
2403: push(@{$allquestids},$id);
2404: %{$$settings{$id}} = ();
2405: %{$varinfo{$id}} = ();
2406: @{$$allchoices{$id}} = ();
2407: @{$$settings{$id}{grps}} = ();
2408: @{$$settings{$id}{lists}} = ();
2409: @{$$settings{$id}{feedback}} = ();
2410: @{$$settings{$id}{str}} = ();
2411: %{$$settings{$id}{strings}} = ();
2412: @{$$settings{$id}{numids}} = ();
2413: %{$$allanswers{$id}} = ();
2414: $$settings{$id}{title} = $attr->{title};
1.53 ! raeburn 2415: $$settings{$id}{title} =~ s/\%/pct_/g;
1.35 raeburn 2416: }
2417: if ("@state" eq "questestinterop item presentation flow material mat_extension webct:calculated webct:var") {
2418: $currvar = $attr->{'webct:name'};
2419: %{$varinfo{$id}{$currvar}} = ();
2420: $varinfo{$id}{$currvar}{min} = $attr->{'webct:min'};
2421: $varinfo{$id}{$currvar}{max} = $attr->{'webct:max'};
2422: $varinfo{$id}{$currvar}{precision} = $attr->{'webct:precision'};
2423: }
2424: if ("@state" eq "questestinterop item presentation flow response_num") {
2425: $numid = $attr->{ident};
2426: push(@{$$settings{$id}{numids}},$numid);
2427: %{$$settings{$id}{$numid}} = ();
2428: %{$$settings{$id}{$numid}{vars}} = ();
2429: @{$$settings{$id}{$numid}{units}} = ();
2430: $$settings{$id}{$numid}{rcardinality} = $attr->{rcardinality};
2431: $$settings{$id}{$numid}{formula} = $formula;
2432: foreach my $var (keys(%{$varinfo{$id}})) {
2433: %{$$settings{$id}{$numid}{vars}{$var}} = %{$varinfo{$id}{$var}};
2434: }
2435: }
2436: if ("@state" eq "questestinterop item presentation flow material mat_extension webct:variable") {
2437: $$settings{$id}{text} .= '['.$attr->{'webct:name'}.']';
2438: }
2439: if ("@state" eq "questestinterop item presentation flow material matimage") {
1.52 raeburn 2440: if ($attr->{uri} =~ /\QRelativeResourceManager?contentID=\E(\d+)$/) {
2441: $$settings{$id}{image} = $1;
2442: push(@{$$resources{$res}{image}},$$settings{$id}{image});
2443: } else {
2444: $$settings{$id}{image} = $attr->{uri};
2445: }
1.35 raeburn 2446: }
2447:
2448: if ("@state" eq "questestinterop item presentation flow material mattext") {
2449: $currtexttype = lc($attr->{texttype});
2450: $$settings{$id}{texttype} = $currtexttype;
2451: if ($$settings{$id}{class} eq 'combination') {
2452: if (exists($attr->{label})) {
2453: $textlabel = $attr->{label};
2454: } else {
2455: $textlabel = '';
2456: }
2457: }
2458: }
2459: if ("@state" eq "questestinterop item presentation flow response_lid") {
2460: $list = $attr->{ident};
2461: push(@{$$settings{$id}{lists}},$list);
2462: %{$$settings{$id}{$list}} = ();
2463: @{$$allanswers{$id}{$list}} = ();
2464: @{$$settings{$id}{$list}{correctanswer}} = ();
1.37 raeburn 2465: @{$$settings{$id}{$list}{jumbledtext}} = ();
2466: @{$$settings{$id}{$list}{jumbledtype}} = ();
1.35 raeburn 2467: @{$$settings{$id}{$list}{jumbled}} = ();
2468: $$settings{$id}{$list}{rcardinality} = $attr->{rcardinality};
2469: }
2470: # Jumbled sentence
2471: if ("@state" eq "questestinterop item presentation flow response_lid render_extension ims_render_object") {
2472: $$settings{$id}{$list}{orientation} = $attr->{orientation};
2473: }
2474: if ("@state" eq "questestinterop item presentation flow response_lid render_extension ims_render_object material mattext") {
2475: $currtexttype = lc($attr->{texttype});
2476: $$settings{$id}{$list}{texttype} = $currtexttype;
2477: }
2478: if ("@state" eq "questestinterop item presentation flow response_lid render_extension ims_render_object response_label") {
2479: $jumble_item = $attr->{ident};
2480: }
2481: if ("@state" eq "questestinterop item presentation flow response_lid render_extension ims_render_object response_label material mattext") {
2482: $currtexttype = lc($attr->{texttype});
2483: $$settings{$id}{$list}{$jumble_item}{texttype} = $currtexttype;
2484: }
1.37 raeburn 2485: if ("@state" eq "questestinterop item resprocessing respcondition") { # Jumbled
2486: if ($$settings{$id}{class} eq 'jumbled') {
2487: $jumbnum ++;
2488: @{$$settings{$id}{$list}{jumbled}[$jumbnum]} = ();
2489: }
2490: }
2491:
1.35 raeburn 2492: if ("@state" eq "questestinterop item resprocessing respcondition conditionvar and varequal") { # Jumbled
2493: $currindex = $attr->{index};
2494: }
2495: if ("@state" eq "questestinterop item presentation flow response_lid render_choice") {
2496: $$settings{$id}{$list}{randomize} = $attr->{shuffle};
2497: }
1.38 raeburn 2498: # Multiple Choice, True/False and Combination
1.35 raeburn 2499: if ("@state" eq "questestinterop item presentation flow response_lid render_choice flow_label response_label") {
2500: $answer_id = $attr->{ident};
2501: push(@{$$allanswers{$id}{$list}},$answer_id);
2502: %{$$settings{$id}{$list}{$answer_id}} = ();
2503: }
2504: # True/False
2505: if ("@state" eq "questestinterop item presentation flow response_lid render_choice flow_label response_label material mat_extension webct:localizable_mattext") {
2506: $currtexttype = lc($attr->{texttype});
2507: $$settings{$id}{$list}{$answer_id}{texttype} = $currtexttype;
2508: }
2509:
2510: # Multiple Choice and Combination
2511: if ("@state" eq "questestinterop item presentation flow response_lid render_choice flow_label response_label material mattext") {
2512: $currtexttype = lc($attr->{texttype});
2513: $$settings{$id}{$list}{$answer_id}{texttype} = $currtexttype;
2514: }
2515:
2516: # String, Shortanswer or Paragraph
2517: if (($$settings{$id}{class} eq 'string') ||
2518: ($$settings{$id}{class} eq 'shortanswer') ||
2519: ($$settings{$id}{class} eq 'paragraph')) {
2520: if ("@state" eq "questestinterop item presentation flow response_str") {
2521: $str_id = $attr->{ident};
2522: %{$$settings{$id}{$str_id}} = ();
2523: push(@{$$settings{$id}{str}},$str_id);
2524: $$settings{$id}{$str_id}{rcardinality} = $attr->{rcardinality};
2525: @{$$settings{$id}{$str_id}{labels}} = ();
2526: %{$$settings{$id}{$str_id}{comparison}} = ();
2527: }
2528: }
2529: if ("@state" eq "questestinterop item presentation flow response_str material mattext") { # string
2530: $currtexttype = lc($attr->{texttype});
2531: $$settings{$id}{$str_id}{texttype} = $currtexttype;
2532: }
2533: if ("@state" eq "questestinterop item presentation flow response_str render_fib") {
2534: $fibtype = $attr->{fibtype};
2535: $prompt = $attr->{prompt};
2536: $rows = $attr->{rows};
2537: $columns = $attr->{columns};
2538: $maxchars = $attr->{maxchars};
2539: }
2540: if ("@state" eq "questestinterop item presentation flow response_str render_fib response_label") {
2541: push(@{$$settings{$id}{$str_id}{labels}},$label);
2542: @{$$settings{$id}{strings}{$str_id}} = ();
2543: %{$$settings{$id}{$str_id}{$label}} = ();
2544: $$settings{$id}{$str_id}{$label}{fibtype} = $fibtype;
2545: if ($$settings{$id}{class} eq 'string') {
1.40 raeburn 2546: $$settings{$id}{text} .= '________';
1.35 raeburn 2547: }
2548: }
2549: if ("@state" eq "questestinterop item presentation flow response_str render_fib response_label material mattext") { # Paragraph
2550: $textlabel = $attr->{label};
2551: }
2552: # Matching
2553: if ("@state" eq "questestinterop item presentation flow flow response_grp") {
2554: $grp = $attr->{ident};
2555: push(@{$$settings{$id}{grps}},$grp);
2556: %{$$settings{$id}{$grp}} = ();
1.38 raeburn 2557: @{$$allanswers{$id}{$grp}} = ();
1.35 raeburn 2558: @{$$settings{$id}{$grp}{correctanswer}} = ();
2559: $$settings{$id}{$grp}{rcardinality} = $attr->{rcardinality};
2560: }
2561: if ("@state" eq "questestinterop item presentation flow flow response_grp material mattext") {
2562: $currtexttype = lc($attr->{texttype});
2563: $$settings{$id}{$grp}{texttype} = $currtexttype;
2564: }
1.38 raeburn 2565: if ("@state" eq "questestinterop item presentation flow flow response_grp render_choice flow_label response_label") {
1.35 raeburn 2566: $answer_id = $attr->{ident};
2567: push(@{$$allanswers{$id}{$grp}},$answer_id);
2568: %{$$settings{$id}{$grp}{$answer_id}} = ();
2569: $currtexttype = lc($attr->{texttype});
2570: $$settings{$id}{$grp}{$answer_id}{texttype} = $currtexttype;
2571: }
2572: # Multiple choice or combination or string or match
2573: if ("@state" eq "questestinterop item resprocessing respcondition conditionvar varequal") {
2574: if (($$settings{$id}{class} eq 'multiplechoice') ||
2575: ($$settings{$id}{class} eq 'combination')) {
2576: $list = $attr->{respident};
2577: } elsif (($$settings{$id}{class} eq 'string') ||
2578: ($$settings{$id}{class} eq 'shortanswer')) {
2579: $label = $attr->{respident};
1.40 raeburn 2580: $$settings{$id}{$label}{case} = $attr->{'case'};
1.35 raeburn 2581: } elsif ($$settings{$id}{class} eq 'match') {
2582: $grp = $attr->{respident};
2583: }
2584: }
2585: if ("@state" eq "questestinterop item resprocessing") {
2586: if (($$settings{$id}{class} eq 'string') ||
2587: ($$settings{$id}{class} eq 'shortanswer')) {
2588: foreach my $str_id (@{$$settings{$id}{str}}) {
2589: @{$str_answers{$str_id}} = ();
2590: }
2591: }
2592: }
2593: if ("@state" eq "questestinterop item resprocessing respcondition") {
2594: if (($$settings{$id}{class} eq 'string') ||
2595: ($$settings{$id}{class} eq 'shortanswer')) {
2596: $numbox ++;
2597: }
2598: }
2599: if ("@state" eq "questestinterop item resprocessing respcondition setvar") {
2600: foreach my $key (keys(%{$attr})) {
2601: $setvar{$key} = $attr->{$key};
2602: }
2603: }
2604: if (($$settings{$id}{class} eq 'string') ||
2605: ($$settings{$id}{class} eq 'shortanswer')) {
2606: if (("@state" eq "questestinterop item resprocessing respcondition conditionvar or varsubset") || ("@state" eq "questestinterop item resprocessing respcondition conditionvar varsubset")) {
2607: $str_id = $attr->{respident};
2608: $$settings{$id}{$str_id}{case} = $attr->{case};
2609: }
2610: }
2611: if ("@state" eq "questestinterop item resprocessing respcondition conditionvar and varsubset") {
2612: $list = $attr->{respident};
2613: }
2614: # Numerical
2615: if ("@state" eq "questestinterop item resprocessing itemproc_extension webct:calculated_answer") {
2616: $numid = $attr->{respident};
2617: $$settings{$id}{$numid}{toltype} = $attr->{'webct:toleranceType'};
2618: $$settings{$id}{$numid}{tolerance} = $attr->{'webct:tolerance'};
2619: }
2620: if ("@state" eq "questestinterop item resprocessing itemproc_extension unit_eval conditionvar varequal") {
2621: $unitid = $attr->{respident};
2622: %{$$settings{$id}{$numid}{$unitid}} = ();
2623: push(@{$$settings{$id}{$numid}{units}},$unitid);
2624: $$settings{$id}{$numid}{$unitid}{case} = $attr->{case};
2625: }
2626: # Feedback
2627: if ("@state" eq "questestinterop item respcondition displayfeedback") {
2628: $fdbk = $attr->{linkrefid};
2629: push(@{$$settings{$id}{feedback}},$fdbk);
2630: $$settings{$id}{$fdbk} = ();
2631: $$settings{$id}{$fdbk}{feedbacktype} = $attr->{feedbacktype};
2632: }
2633: if ("@state" eq "questestinterop item itemfeedback") {
2634: $fdbk = $attr->{ident};
2635: push(@{$$settings{$id}{feedback}},$fdbk);
2636: $$settings{$id}{$fdbk}{view} = $attr->{view};
2637: }
2638: if ("@state" eq "questestinterop item itemfeedback material mattext") {
2639: $currtexttype = lc($attr->{texttype});
2640: $$settings{$id}{$fdbk}{texttype} = $currtexttype;
2641: }
2642: if ("@state" eq "questestinterop item itemfeedback solution solutionmaterial material mattext") {
2643: $currtexttype = lc($attr->{texttype});
2644: $$settings{$id}{$fdbk}{texttype} = $currtexttype;
2645: }
2646: }, "tagname, attr"],
2647: text_h =>
2648: [sub {
2649: my ($text) = @_;
1.53 ! raeburn 2650: $text =~ s/\s*\&\s*/_and_/g;
1.35 raeburn 2651: if ($currtexttype eq '/text/html') {
2652: $text =~ s#(<img\ssrc=")([^"]+)">#$1../resfiles/$2#g;
2653: }
1.52 raeburn 2654: if ("@state" eq "questestinterop item presentation flow material matimage") {
1.53 ! raeburn 2655: my $imagetitle;
! 2656: if ($text =~ /,/) {
! 2657: $imagetitle = (split(/,/,$text))[-1];
! 2658: } else {
! 2659: $imagetitle = $text;
! 2660: }
1.52 raeburn 2661: $$settings{$id}{imagetitle} = $imagetitle;
2662: push(@{$$resources{$res}{imagetitle}},$imagetitle);
2663: }
1.35 raeburn 2664: if ("@state" eq "questestinterop item itemmetadata qtimetadata qtimetadatafield fieldlabel") {
2665: $fieldlabel = $text;
2666: }
2667: if ("@state" eq "questestinterop item itemmetadata qtimetadata qtimetadatafield fieldentry") {
2668: $questiondata{$fieldlabel} = $text;
2669: if ($fieldlabel eq 'wct_questiontype') {
2670: $$settings{$id}{class} = $classtypes{$text};
2671: } elsif ($fieldlabel eq 'wct_questioncategory') {
2672: $$settings{$id}{category} = $text;
2673: unless(exists($$catinfo{$text})) {
2674: %{$$catinfo{$text}} = ();
2675: $$catinfo{$text}{title} = $text;
2676: }
2677: push(@{$$catinfo{$text}{contents}},$id);
2678: }
2679: }
2680: if ("@state" eq "questestinterop item presentation flow material mat_extension webct:calculated webct:formula") {
2681: $formula = $text;
2682: }
2683: if ("@state" eq "questestinterop item presentation flow response_str material mattext") {
2684: $$settings{$id}{$str_id}{text} = $text;
2685: }
2686: if ("@state" eq "questestinterop item presentation flow response_str render_fib response_label material mattext") { # Paragraph
2687: if ($textlabel eq 'PRE_FILL_ANSWER') {
2688: $$settings{$id}{$str_id}{$label}{$textlabel} = $text;
2689: }
2690: }
1.38 raeburn 2691: # Matching
1.35 raeburn 2692: if ("@state" eq "questestinterop item presentation flow response_lid render_choice flow_label response_label material mattext") {
2693: $$settings{$id}{$list}{$answer_id}{text} .= $text;
2694: }
1.38 raeburn 2695: # Multiple choice, True/False, Combination
1.35 raeburn 2696: if ("@state" eq "questestinterop item presentation flow response_lid render_choice flow_label response_label material mat_extension webct:localizable_mattext") {
2697: $$settings{$id}{$list}{$answer_id}{text} = $text;
2698: }
2699: if ("@state" eq "questestinterop item presentation flow response_lid render_extension ims_render_object material mattext") {
1.37 raeburn 2700: push(@{$$settings{$id}{$list}{jumbledtext}},$text);
2701: push(@{$$settings{$id}{$list}{jumbledtype}},'No');
1.35 raeburn 2702: }
2703: if ("@state" eq "questestinterop item presentation flow response_lid render_extension ims_render_object response_label material mattext") {
2704: $$settings{$id}{$list}{$jumble_item}{text} = $text;
1.37 raeburn 2705: push(@{$$settings{$id}{$list}{jumbledtext}},$text);
2706: push(@{$$settings{$id}{$list}{jumbledtype}},'Yes');
1.35 raeburn 2707: }
2708: if ("@state" eq "questestinterop item presentation flow material mattext") {
2709: $$settings{$id}{text} .= $text;
2710: if ($$settings{$id}{class} eq 'combination') {
2711: if ($textlabel =~ /^wct_question_label_\d+$/) {
1.36 raeburn 2712: $$settings{$id}{text} .= '<br />';
1.35 raeburn 2713: }
1.36 raeburn 2714: if ($textlabel =~ /^wct_cmc_single_answer\d+$/) {
2715: $$settings{$id}{text} .= '<br />';
1.35 raeburn 2716: }
2717: }
2718: }
1.38 raeburn 2719: # Matching
2720: if ("@state" eq "questestinterop item presentation flow flow response_grp material mattext") {
2721: $$settings{$id}{$grp}{text} = $text;
2722: unless ($text eq '') {
2723: push(@{$$allchoices{$id}},$grp);
2724: }
2725: }
2726: if ("@state" eq "questestinterop item presentation flow flow response_grp render_choice flow_label response_label material mattext") {
2727: $$settings{$id}{$grp}{$answer_id}{text} = $text;
2728: }
2729: # Numerical
1.35 raeburn 2730: if ("@state" eq "questestinterop item resprocessing itemproc_extension unit_eval conditionvar varequal") {
2731: $$settings{$id}{$numid}{$unitid}{text} = $text;
2732: }
2733: if ("@state" eq "questestinterop item resprocessing respcondition conditionvar varequal") {
2734: if (($$settings{$id}{class} eq 'string') ||
2735: ($$settings{$id}{class} eq 'shortanswer')) {
2736: unless (grep/^$text$/,@{$str_answers{$str_id}}) {
2737: push(@{$str_answers{$str_id}},$text);
2738: $$settings{$id}{$str_id}{comparison}{$text} = $questiondata{'wct_comparison_type'.$numbox};
2739: }
2740: } else {
2741: $answer_id = $text;
2742: }
2743: }
2744: if (("@state" eq "questestinterop item resprocessing respcondition conditionvar or varsubset") || ("@state" eq "questestinterop item resprocessing respcondition conditionvar varsubset")) { # string
2745: if (($$settings{$id}{class} eq 'string') ||
2746: ($$settings{$id}{class} eq 'shortanswer')) {
2747: unless (grep/^$text$/,@{$str_answers{$str_id}}) {
2748: push(@{$str_answers{$str_id}},$text);
2749: $$settings{$id}{$str_id}{comparison}{$text} = $questiondata{'wct_comparison_type'.$numbox};
2750: }
2751: }
2752: }
1.37 raeburn 2753:
1.35 raeburn 2754: if ("@state" eq "questestinterop item resprocessing respcondition conditionvar and varequal") { # Jumbled
1.37 raeburn 2755: $$settings{$id}{$list}{jumbled}[$jumbnum][$currindex] = $text;
1.35 raeburn 2756: }
2757: if ("@state" eq "questestinterop item resprocessing respcondition setvar") {
2758: if ($setvar{varname} eq "SCORE") { # Multiple Choice, String or Match
2759: if ($text =~ m/^[\d\.]+$/) {
2760: if ($text > 0) {
2761: if (($$settings{$id}{class} eq 'multiplechoice') ||
2762: ($$settings{$id}{class} eq 'combination')) {
2763: push(@{$$settings{$id}{$list}{correctanswer}},$answer_id);
2764: } elsif (($$settings{$id}{class} eq 'string') ||
2765: ($$settings{$id}{class} eq 'shortanswer')) {
2766: foreach my $answer (@{$str_answers{$str_id}}) {
2767: unless (grep/^$answer$/,@{$$settings{$id}{strings}{$str_id}}) {
2768: push(@{$$settings{$id}{strings}{$str_id}},$answer);
2769: }
2770: }
2771: } elsif ($$settings{$id}{class} eq 'match') {
2772: push(@{$$settings{$id}{$grp}{correctanswer}},$answer_id);
2773: }
2774: }
2775: }
2776: }
2777: }
2778: if ("@state" eq "questestinterop item itemfeedback material mattext") {
2779: $$settings{$id}{$fdbk}{text} = $text;
2780: }
2781: if ("@state" eq "questestinterop item itemfeedback solution solutionmaterial material mattext") {
2782: $$settings{$id}{$fdbk}{text} = $text;
2783: }
2784: }, "dtext"],
2785: end_h =>
2786: [sub {
2787: my ($tagname) = @_;
2788: pop @state;
2789: }, "tagname"],
2790: );
2791: $p->unbroken_text(1);
2792: $p->parse_file($xmlfile);
2793: $p->eof;
2794: }
2795:
1.15 raeburn 2796: sub parse_webct4_assessment {
1.16 raeburn 2797: my ($res,$docroot,$href,$container,$allids) = @_;
2798: my $xmlfile = $docroot.'/'.$href; #quiz file
1.15 raeburn 2799: my @state = ();
2800: my $id; # the current question ID
2801: my $p = HTML::Parser->new
2802: (
2803: xml_mode => 1,
2804: start_h =>
2805: [sub {
2806: my ($tagname, $attr) = @_;
2807: push @state, $tagname;
2808: my $depth = 0;
2809: my @seq = ();
2810: if ("@state" eq "questestinterop assessment section itemref") {
2811: $id = $attr->{linkrefid};
2812: push(@{$allids},$id);
2813: }
2814: }, "tagname, attr"],
2815: text_h =>
2816: [sub {
2817: my ($text) = @_;
2818: }, "dtext"],
2819: end_h =>
2820: [sub {
2821: my ($tagname) = @_;
2822: pop @state;
2823: }, "tagname"],
2824: );
2825: $p->unbroken_text(1);
2826: $p->parse_file($xmlfile);
2827: $p->eof;
2828: }
2829:
1.16 raeburn 2830: sub parse_webct4_quizprops {
2831: my ($res,$docroot,$href,$container,$qzparams) = @_;
2832: my $xmlfile = $docroot.'/'.$href; #properties file
1.15 raeburn 2833: my @state = ();
2834: %{$$qzparams{$res}} = ();
2835: my $p = HTML::Parser->new
2836: (
2837: xml_mode => 1,
2838: start_h =>
2839: [sub {
2840: my ($tagname, $attr) = @_;
2841: push @state, $tagname;
2842: }, "tagname, attr"],
2843: text_h =>
2844: [sub {
2845: my ($text) = @_;
2846: if ($state[0] eq 'properties' && $state[1] eq 'delivery') {
1.16 raeburn 2847: if ($state[2] eq 'time_available') {
1.15 raeburn 2848: $$qzparams{$res}{opendate} = $text;
1.16 raeburn 2849: } elsif ($state[2] eq 'time_due') {
1.18 raeburn 2850: $$qzparams{$res}{duedate} = $text;
1.16 raeburn 2851: } elsif ($state[3] eq 'max_attempt') {
1.15 raeburn 2852: $$qzparams{$res}{tries} = $text;
1.16 raeburn 2853: } elsif ($state[3] eq 'post_submission') {
1.15 raeburn 2854: $$qzparams{$res}{posts} = $text;
1.18 raeburn 2855: } elsif ($state[3] eq 'method') {
2856: $$qzparams{$res}{method} = $text;
2857: }
2858: } elsif ($state[0] eq 'properties' && $state[1] eq 'processing') {
2859: if ($state[2] eq 'scores' && $state[3] eq 'score') {
2860: $$qzparams{$res}{weight} = $text;
2861: } elsif ($state[2] eq 'selection' && $state[3] eq 'select') {
2862: $$qzparams{$res}{numpick} = $text;
1.16 raeburn 2863: }
1.15 raeburn 2864: } elsif ($state[0] eq 'properties' && $state[1] eq 'result') {
1.16 raeburn 2865: if ($state[2] eq 'display_answer') {
1.18 raeburn 2866: $$qzparams{$res}{showanswer} = $text;
1.16 raeburn 2867: }
1.15 raeburn 2868: }
2869: }, "dtext"],
2870: end_h =>
2871: [sub {
2872: my ($tagname) = @_;
2873: pop @state;
2874: }, "tagname"],
2875: );
2876: $p->unbroken_text(1);
2877: $p->parse_file($xmlfile);
2878: $p->eof;
2879: }
2880:
2881: sub parse_webct4_questionDB {
1.16 raeburn 2882: my ($docroot,$href,$catinfo,$settings,$allanswers,$allchoices,$allids) = @_;
1.44 raeburn 2883: my $xmlfile;
2884: if ($href eq 'questiondb.xml') {
2885: $xmlfile = $docroot.'/'.$href;
2886: } else {
2887: $href =~ s#[^/]+$##;
2888: $xmlfile = $docroot.'/'.$href.'questionDB.xml'; #quizDB file
2889: }
1.15 raeburn 2890: my @state = ();
2891: my $category; # the current category ID
2892: my $id; # the current question ID
2893: my $list; # the current list ID for multiple choice questions
2894: my $numid; # the current answer ID for numerical questions
2895: my $grp; # the current group ID for matching questions
2896: my $label; # the current reponse label for string questions
2897: my $str_id; # the current string ID for string questions
2898: my $unitid; # the current unit ID for numerical questions
2899: my $answer_id; # the current answer ID
2900: my $fdbk; # the current feedback ID
1.16 raeburn 2901: my $currvar; # the current variable for numerical problems
2902: my $fibtype; # the current fill-in-blank type for numerical or string
2903: my $prompt;
2904: my $boxnum;
1.15 raeburn 2905: my %setvar = (
2906: varname => '',
2907: action => '',
1.16 raeburn 2908: );
2909: my $currtexttype;
1.44 raeburn 2910: my $currimagtype;
2911: my $is_objectbank;
1.15 raeburn 2912: my $p = HTML::Parser->new
2913: (
2914: xml_mode => 1,
2915: start_h =>
2916: [sub {
2917: my ($tagname, $attr) = @_;
1.44 raeburn 2918: if (("@state" eq "questestinterop") && ($tagname eq 'objectbank')) {
2919: $is_objectbank = 1;
2920: } else {
2921: push @state, $tagname;
2922: }
1.15 raeburn 2923: if ("@state" eq "questestinterop section") {
2924: $category = $attr->{ident};
2925: %{$$catinfo{$category}} = ();
2926: $$catinfo{$category}{title} = $attr->{title};
2927: }
2928: if ("@state" eq "questestinterop section item") {
2929: $id = $attr->{ident};
2930: push @{$allids}, $id;
2931: push(@{$$catinfo{$category}{contents}},$id);
2932: %{$$settings{$id}} = ();
1.16 raeburn 2933: @{$$allchoices{$id}} = ();
1.15 raeburn 2934: @{$$settings{$id}{grps}} = ();
2935: @{$$settings{$id}{lists}} = ();
2936: @{$$settings{$id}{feedback}} = ();
1.16 raeburn 2937: @{$$settings{$id}{str}} = ();
1.15 raeburn 2938: %{$$settings{$id}{strings}} = ();
1.16 raeburn 2939: @{$$settings{$id}{numids}} = ();
2940: @{$$settings{$id}{boxes}} = ();
1.15 raeburn 2941: %{$$allanswers{$id}} = ();
2942: $$settings{$id}{title} = $attr->{title};
1.16 raeburn 2943: $$settings{$id}{category} = $category;
2944: $boxnum = 0;
1.15 raeburn 2945: }
2946:
2947: if ("@state" eq "questestinterop section item presentation material mattext") {
2948: $$settings{$id}{texttype} = $attr->{texttype};
1.16 raeburn 2949: $currtexttype = $attr->{texttype};
1.15 raeburn 2950: }
1.16 raeburn 2951: if ("@state" eq "questestinterop section item presentation material matimage") {
2952: $$settings{$id}{imagtype} = $attr->{imagtype};
2953: $currimagtype = $attr->{imagtype};
2954: $$settings{$id}{uri} = $attr->{uri};
2955: }
2956:
2957: # Matching
1.15 raeburn 2958: if ("@state" eq "questestinterop section item presentation response_grp") {
1.16 raeburn 2959: $$settings{$id}{class} = 'match';
1.15 raeburn 2960: $grp = $attr->{ident};
2961: push(@{$$settings{$id}{grps}},$grp);
2962: %{$$settings{$id}{$grp}} = ();
2963: @{$$settings{$id}{$grp}{correctanswer}} = ();
2964: $$settings{$id}{$grp}{rcardinality} = $attr->{rcardinality};
2965: }
2966: if ("@state" eq "questestinterop section item presentation response_grp material mattext") {
2967: $$settings{$id}{$grp}{texttype} = $attr->{texttype};
1.16 raeburn 2968: $currtexttype = $attr->{texttype};
1.15 raeburn 2969: }
2970: if ("@state" eq "questestinterop section item presentation response_grp render_choice response_label") {
2971: $answer_id = $attr->{ident};
2972: push(@{$$allanswers{$id}{$grp}},$answer_id);
2973: %{$$settings{$id}{$grp}{$answer_id}} = ();
2974: $$settings{$id}{$grp}{$answer_id}{texttype} = $attr->{texttype};
1.16 raeburn 2975: $currtexttype = $attr->{texttype};
1.15 raeburn 2976: }
2977:
2978: # Multiple choice
2979:
2980: if ("@state" eq "questestinterop section item presentation flow material mattext") {
2981: $$settings{$id}{texttype} = $attr->{texttype};
1.16 raeburn 2982: $currtexttype = $attr->{texttype};
1.15 raeburn 2983: }
1.41 raeburn 2984: if ("@state" eq "questestinterop section item presentation flow material matimage") {
2985: $$settings{$id}{imagtype} = $attr->{imagtype};
2986: $currimagtype = $attr->{imagtype};
2987: $$settings{$id}{uri} = $attr->{uri};
2988:
2989: }
1.15 raeburn 2990: if ("@state" eq "questestinterop section item presentation flow response_lid") {
1.16 raeburn 2991: $$settings{$id}{class} = 'multiplechoice';
1.15 raeburn 2992: $list = $attr->{ident};
2993: push(@{$$settings{$id}{lists}},$list);
2994: %{$$settings{$id}{$list}} = ();
2995: @{$$allanswers{$id}{$list}} = ();
2996: @{$$settings{$id}{$list}{correctanswer}} = ();
2997: $$settings{$id}{$list}{rcardinality} = $attr->{rcardinality};
2998: }
2999: if ("@state" eq "questestinterop section item presentation flow response_lid render_choice") {
3000: $$settings{$id}{$list}{randomize} = $attr->{shuffle};
3001: }
3002: if ("@state" eq "questestinterop section item presentation flow response_lid render_choice flow_label response_label") {
3003: $answer_id = $attr->{ident};
3004: push(@{$$allanswers{$id}{$list}},$answer_id);
3005: %{$$settings{$id}{$list}{$answer_id}} = ();
3006: }
3007: if ("@state" eq "questestinterop section item presentation flow response_lid render_choice flow_label response_label material mattext") {
3008: $$settings{$id}{$list}{$answer_id}{texttype} = $attr->{texttype};
1.16 raeburn 3009: $currtexttype = $attr->{texttype};
1.15 raeburn 3010: }
1.44 raeburn 3011: if ("@state" eq "questestinterop section item presentation flow response_lid render_choice flow_label response_label flow_mat material mattext") {
3012: $$settings{$id}{$list}{$answer_id}{texttype} = $attr->{texttype};
3013: $currtexttype = $attr->{texttype};
3014: }
1.15 raeburn 3015:
3016: # Numerical
3017: if ("@state" eq "questestinterop section item presentation material mat_extension webct:x_webct_v01_dynamicmattext") {
3018: $$settings{$id}{texttype} = $attr->{texttype};
1.16 raeburn 3019: $currtexttype = $attr->{texttype};
1.15 raeburn 3020: }
3021: if ("@state" eq "questestinterop section item presentation response_num") {
1.16 raeburn 3022: $$settings{$id}{class} = 'numerical';
1.15 raeburn 3023: $numid = $attr->{ident};
1.16 raeburn 3024: push(@{$$settings{$id}{numids}},$numid);
1.15 raeburn 3025: %{$$settings{$id}{$numid}} = ();
1.16 raeburn 3026: %{$$settings{$id}{$numid}{vars}} = ();
3027: @{$$settings{$id}{$numid}{units}} = ();
1.15 raeburn 3028: $$settings{$id}{$numid}{rcardinality} = $attr->{rcardinality};
3029: }
3030: if ("@state" eq "questestinterop section item presentation response_num material mat_extension webct:x_webct_v01_dynamicdata webct:x_webct_v01_datarange webct:x_webct_v01_minvalue webct:x_webct_v01_variable") {
1.16 raeburn 3031: $currvar = $attr->{name};
3032: %{$$settings{$id}{$numid}{vars}{$currvar}} = ();
1.15 raeburn 3033: }
1.16 raeburn 3034: if ("@state" eq "questestinterop section item presentation response_num material mat_extension webct:x_webct_v01_dynamicdata webct:x_webct_v01_datarange webct:x_webct_v01_maxvalue webct:x_webct_v01_variable") {
3035: $currvar = $attr->{name};
1.15 raeburn 3036: }
3037: if ("@state" eq "questestinterop section item presentation response_num material mat_extension webct:x_webct_v01_dynamicdata webct:x_webct_v01_datarange webct:x_webct_v01_decimalnum webct:x_webct_v01_variable") {
1.16 raeburn 3038: $currvar = $attr->{name};
1.15 raeburn 3039: }
3040: if ("@state" eq "questestinterop section item presentation response_num render_fib") {
3041: $fibtype = $attr->{fibtype};
3042: $prompt = $attr->{prompt};
3043: }
3044: if ("@state" eq "questestinterop section item presentation response_num render_fib response_label") {
3045: $$settings{$id}{$numid}{label} = $attr->{ident};
3046: }
3047:
3048: # String or Numerical
3049: if ("@state" eq "questestinterop section item presentation response_str") {
3050: $str_id = $attr->{ident};
3051: push(@{$$settings{$id}{str}},$str_id);
1.16 raeburn 3052: @{$$settings{$id}{boxes}[$boxnum]} = ();
3053: $boxnum ++;
1.15 raeburn 3054: %{$$settings{$id}{$str_id}} = ();
1.16 raeburn 3055: @{$$settings{$id}{$str_id}{labels}} = ();
1.15 raeburn 3056: $$settings{$id}{$str_id}{rcardinality} = $attr->{rcardinality};
3057: }
3058:
3059: if ("@state" eq "questestinterop section item presentation response_str render_fib") {
3060: $fibtype = $attr->{fibtype};
1.16 raeburn 3061: $prompt = $attr->{prompt};
1.15 raeburn 3062: }
3063: if ("@state" eq "questestinterop section item presentation response_str render_fib response_label") {
3064: $label = $attr->{ident};
1.16 raeburn 3065: push(@{$$settings{$id}{$str_id}{labels}},$label);
3066: @{$$settings{$id}{strings}{$label}} = ();
1.15 raeburn 3067: %{$$settings{$id}{$str_id}{$label}} = ();
3068: $$settings{$id}{$str_id}{$label}{fibtype} = $fibtype;
3069: }
3070:
3071: # Numerical
3072: if ("@state" eq "questestinterop section item resprocessing itemproc_extension webct:x_webct_v01_autocalculate webct:x_webct_v01_anspresentation") {
3073: $$settings{$id}{$numid}{digits} = $attr->{digits};
3074: $$settings{$id}{$numid}{format} = $attr->{format};
3075: }
3076: if ("@state" eq "questestinterop section item resprocessing itemproc_extension webct:x_webct_v01_autocalculate webct:x_webct_v01_anstolerance") {
3077: $$settings{$id}{$numid}{toltype} = $attr->{type};
3078: }
3079: if ("@state" eq "questestinterop section item resprocessing itemproc_extension webct:x_webct_v01_autocalculate webct:x_webct_v01_unit") {
1.26 raeburn 3080: $unitid = $attr->{ident};
1.15 raeburn 3081: %{$$settings{$id}{$numid}{$unitid}} = ();
1.16 raeburn 3082: push(@{$$settings{$id}{$numid}{units}},$unitid);
1.15 raeburn 3083: $$settings{$id}{$numid}{$unitid}{value} = $attr->{value};
3084: $$settings{$id}{$numid}{$unitid}{space} = $attr->{space};
3085: $$settings{$id}{$numid}{$unitid}{case} = $attr->{case};
3086: }
3087:
3088: # Matching
3089: if ("@state" eq "questestinterop section item resprocessing respcondition conditionvar varequal") {
1.16 raeburn 3090: if ($$settings{$id}{class} eq 'match') {
3091: unless ($attr->{respident} eq 'WebCT_Incorrect') {
3092: $grp = $attr->{respident};
3093: }
3094: # String
3095: } else {
3096: $label = $attr->{respident};
3097: $$settings{$id}{$label}{case} = $attr->{case};
3098: }
1.15 raeburn 3099: }
1.16 raeburn 3100: if ("@state" eq "questestinterop section item resprocessing respcondition setvar") {
1.44 raeburn 3101: foreach my $key (keys(%{$attr})) {
3102: $setvar{$key} = $attr->{$key};
3103: }
1.15 raeburn 3104: if ($setvar{varname} eq 'WebCT_Correct') {
3105: push(@{$$settings{$id}{$grp}{correctanswer}},$answer_id);
3106: }
3107: }
3108:
1.16 raeburn 3109: # String
3110: if ("@state" eq "questestinterop section item resprocessing") {
3111: $boxnum = -1;
3112: }
3113: if ("@state" eq "questestinterop section item resprocessing respcondition") { $boxnum ++;
3114: }
1.15 raeburn 3115: if ("@state" eq "questestinterop section item resprocessing respcondition conditionvar varsubset") {
1.16 raeburn 3116: $$settings{$id}{class} = 'string';
3117: $label = $attr->{respident};
1.15 raeburn 3118: }
3119: if ("@state" eq "questestinterop section item resprocessing respcondition conditionvar not") {
1.16 raeburn 3120: $$settings{$id}{class} = 'paragraph';
1.15 raeburn 3121: }
3122:
3123:
3124: # Feedback
3125:
3126: if ("@state" eq "questestinterop section item respcondition displayfeedback") {
3127: $fdbk = $attr->{linkrefid};
3128: push(@{$$settings{$id}{feedback}},$fdbk);
3129: $$settings{$id}{$fdbk} = ();
3130: $$settings{$id}{$fdbk}{feedbacktype} = $attr->{feedbacktype};
3131: }
3132: if ("@state" eq "questestinterop section item itemfeedback") {
3133: $fdbk = $attr->{ident};
1.44 raeburn 3134: push(@{$$settings{$id}{feedback}},$fdbk);
1.15 raeburn 3135: $$settings{$id}{$fdbk}{view} = $attr->{view};
3136: }
3137: if ("@state" eq "questestinterop section item itemfeedback material mattext") {
3138: $$settings{$id}{$fdbk}{texttype} = $attr->{texttype};
1.16 raeburn 3139: $currtexttype = $attr->{texttype};
1.15 raeburn 3140: }
3141: }, "tagname, attr"],
3142: text_h =>
3143: [sub {
3144: my ($text) = @_;
1.16 raeburn 3145: if ($currtexttype eq '/text/html') {
3146: $text =~ s#(<img\ssrc=")([^"]+)">#$1../resfiles/$2#g;
3147: }
1.15 raeburn 3148: if ("@state" eq "questestinterop section item itemmetadata qmd_itemtype") {
3149: $$settings{$id}{itemtype} = $text;
1.16 raeburn 3150: if ($text eq 'String') {
3151: $$settings{$id}{class} = 'string';
3152: }
1.15 raeburn 3153: }
3154:
3155: if ("@state" eq "questestinterop section item presentation material mattext") {
3156: $$settings{$id}{text} = $text;
3157: }
1.16 raeburn 3158: # Matching
1.15 raeburn 3159: if ("@state" eq "questestinterop section item presentation response_grp material mattext") {
3160: $$settings{$id}{$grp}{text} = $text;
1.16 raeburn 3161: unless ($text eq '') {
3162: push(@{$$allchoices{$id}},$grp);
3163: }
1.15 raeburn 3164: }
3165: if ("@state" eq "questestinterop section item presentation response_grp render_choice response_label material mattext") {
3166: $$settings{$id}{$grp}{$answer_id}{text} = $text;
3167: }
3168:
3169: # Multiple choice
3170:
3171: if ("@state" eq "questestinterop section item presentation flow material mattext") {
3172: $$settings{$id}{text} = $text;
3173: }
3174:
3175: if ("@state" eq "questestinterop section item presentation flow response_lid render_choice flow_label response_label material mattext") {
3176: $$settings{$id}{$list}{$answer_id}{text} = $text;
3177: }
1.44 raeburn 3178: if ("@state" eq "questestinterop section item presentation flow response_lid render_choice flow_label response_label flow_mat material mattext") {
3179: $$settings{$id}{$list}{$answer_id}{text} = $text;
3180: }
1.15 raeburn 3181:
3182: # Numerical
3183: if ("@state" eq "questestinterop section item presentation material mat_extension webct:x_webct_v01_dynamicmattext") {
3184: $$settings{$id}{text} = $text;
3185: }
3186: if ("@state" eq "questestinterop section item presentation response_num material mat_extension webct:x_webct_v01_dynamicdata webct:x_webct_v01_datarange webct:x_webct_v01_minvalue webct:x_webct_v01_variable") {
1.16 raeburn 3187: $$settings{$id}{$numid}{vars}{$currvar}{min} = $text;
1.15 raeburn 3188: }
3189: if ("@state" eq "questestinterop section item presentation response_num material mat_extension webct:x_webct_v01_dynamicdata webct:x_webct_v01_datarange webct:x_webct_v01_maxvalue webct:x_webct_v01_variable") {
1.16 raeburn 3190: $$settings{$id}{$numid}{vars}{$currvar}{max} = $text;
1.15 raeburn 3191: }
3192: if ("@state" eq "questestinterop section item presentation response_num material mat_extension webct:x_webct_v01_dynamicdata webct:x_webct_v01_datarange webct:x_webct_v01_decimalnum webct:x_webct_v01_variable") {
1.16 raeburn 3193: $$settings{$id}{$numid}{vars}{$currvar}{dec} = $text;
3194: }
3195: if ("@state" eq "questestinterop section item resprocessing itemproc_extension webct:x_webct_v01_autocalculate webct:x_webct_v01_formula") {
3196: $$settings{$id}{$numid}{formula} = $text;
1.15 raeburn 3197: }
3198: if ("@state" eq "questestinterop section item resprocessing respcondition conditionvar varequal") {
1.16 raeburn 3199: if ($$settings{$id}{class} eq 'string') {
3200: unless (grep/^$text$/,@{$$settings{$id}{strings}{$label}}) {
3201: push(@{$$settings{$id}{strings}{$label}},$text);
3202: }
3203: unless (grep/^$text$/,@{$$settings{$id}{boxes}[$boxnum]}) {
3204: push(@{$$settings{$id}{boxes}[$boxnum]},$text);
3205: }
3206: } else {
3207: $answer_id = $text;
3208: }
1.15 raeburn 3209: }
3210: if ("@state" eq "questestinterop section item resprocessing respcondition conditionvar varsubset") { # String
1.16 raeburn 3211: unless (grep/^$text$/,@{$$settings{$id}{strings}{$label}}) {
3212: push(@{$$settings{$id}{strings}{$label}},$text);
3213: }
3214: unless (grep/^$text$/,@{$$settings{$id}{boxes}[$boxnum]}) {
3215: push(@{$$settings{$id}{boxes}[$boxnum]},$text);
3216: }
1.15 raeburn 3217: }
1.16 raeburn 3218: if ("@state" eq "questestinterop section item resprocessing respcondition setvar") {
1.41 raeburn 3219: if ($setvar{varname} eq "answerValue") { # Multiple Choice WebCT4.0
1.15 raeburn 3220: if ($text =~ m/^\d+$/) {
3221: if ($text > 0) {
1.16 raeburn 3222: push(@{$$settings{$id}{$list}{correctanswer}},$answer_id);
1.15 raeburn 3223: }
3224: }
1.41 raeburn 3225: } elsif ($setvar{varname} eq "que_score") { # Multiple Choice WebCT4.1
3226: if ($text =~ m/^\d+$/) {
3227: if ($text > 0) {
3228: push(@{$$settings{$id}{$list}{correctanswer}},$answer_id);
3229: }
3230: }
1.44 raeburn 3231: } elsif ($is_objectbank) { #Multiple Choice WebCT 4.1 D2L objectbank
3232: if ($setvar{action} eq "Set") {
3233: if ($text =~ /^\d+\.?\d*$/) {
3234: if ($text > 0.000000001) {
3235: push(@{$$settings{$id}{$list}{correctanswer}},$answer_id);
3236: }
3237: }
3238: }
1.15 raeburn 3239: }
3240: }
1.16 raeburn 3241: if ("@state" eq "questestinterop section item resprocessing itemproc_extension webct:x_webct_v01_autocalculate webct:x_webct_v01_anstolerance") {
3242: $$settings{$id}{$numid}{tolerance} = $text;
3243: }
1.15 raeburn 3244: if ("@state" eq "questestinterop section item resprocessing itemproc_extension webct:x_webct_v01_autocalculate webct:x_webct_v01_unit") {
3245: $$settings{$id}{$numid}{$unitid}{text} = $text;
3246: }
3247:
3248: if ("@state" eq "questestinterop section item itemfeedback material mattext") {
3249: $$settings{$id}{$fdbk}{text} = $text;
3250: }
3251: }, "dtext"],
3252: end_h =>
3253: [sub {
3254: my ($tagname) = @_;
1.44 raeburn 3255: if (("@state" eq "questestinterop") && ($tagname eq 'objectbank')) {
3256: $is_objectbank = '';
3257: } else {
3258: pop @state;
3259: }
1.15 raeburn 3260: }, "tagname"],
3261: );
3262: $p->unbroken_text(1);
3263: $p->parse_file($xmlfile);
3264: $p->eof;
1.16 raeburn 3265: my $boxcount;
3266: foreach my $id (keys %{$settings}) {
3267: if ($$settings{$id}{class} eq 'string') {
3268: $boxcount = 0;
3269: if (@{$$settings{$id}{boxes}} > 1) {
3270: foreach my $str_id (@{$$settings{$id}{str}}) {
3271: foreach my $label (@{$$settings{$id}{$str_id}{labels}}) {
3272: @{$$settings{$id}{strings}{$label}} = @{$$settings{$id}{boxes}[$boxcount]};
3273: $boxcount ++;
3274: }
3275: }
3276: }
1.44 raeburn 3277: } elsif ($$settings{$id}{class} eq 'multiplechoice') {
3278: if (ref($$settings{$id}) eq 'HASH') {
3279: foreach my $list (keys(%{$$settings{$id}})) {
3280: if (ref($$settings{$id}{$list}) eq 'HASH') {
3281: if (defined($$settings{$id}{$list}{rcardinality})) {
3282: if ($$settings{$id}{$list}{rcardinality} eq 'Multiple') {
3283: if (ref($$settings{$id}{$list}{correctanswer}) eq 'ARRAY') {
3284: if (@{$$settings{$id}{$list}{correctanswer}} == 1) {
3285: $$settings{$id}{$list}{rcardinality} = 'Single';
3286: }
3287: }
3288: }
3289: }
3290: }
3291: }
3292: }
1.16 raeburn 3293: }
3294: }
1.15 raeburn 3295: }
1.2 raeburn 3296:
1.15 raeburn 3297: sub process_assessment {
1.35 raeburn 3298: my ($cms,$context,$res,$docroot,$container,$dirname,$destdir,$settings,$total,$udom,$uname,$pagesfiles,$sequencesfiles,$randompicks,$dbparse,$resources,$items,$catinfo,$qzdbsettings,$hrefs,$allquestions) = @_;
1.15 raeburn 3299: my @allids = ();
1.35 raeburn 3300: my @allquestids = ();
1.15 raeburn 3301: my %allanswers = ();
3302: my %allchoices = ();
3303: my %qzparams = ();
3304: my %alldbanswers = ();
3305: my %alldbchoices = ();
3306: my @alldbquestids = ();
3307: my $containerdir;
3308: my $newdir;
3309: my $randompickflag = 0;
3310: my ($cid,$cdom,$cnum);
3311: if ($context eq 'DOCS') {
1.19 albertel 3312: $cid = $env{'request.course.id'};
1.15 raeburn 3313: ($cdom,$cnum) = split/_/,$cid;
3314: }
3315: my $destresdir = $destdir;
1.50 raeburn 3316: my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
1.15 raeburn 3317: if ($context eq 'CSTR') {
1.50 raeburn 3318: $destresdir =~ s{^\Q$londocroot/priv/\E}{/res/};
1.15 raeburn 3319: } elsif ($context eq 'DOCS') {
1.50 raeburn 3320: $destresdir =~ s{^\Q$londocroot/userfiles\E}{/uploaded};
1.15 raeburn 3321: }
3322: if ($cms eq 'bb5') {
3323: &parse_bb5_assessment($res,$docroot,$container,$settings,\%allanswers,\%allchoices,\@allids);
3324: } elsif ($cms eq 'bb6') {
1.30 raeburn 3325: &parse_bb6_assessment($res,$docroot,$container,$settings,\@allids);
1.34 raeburn 3326: } elsif ($cms eq 'webctce4') {
1.15 raeburn 3327: unless($$dbparse) {
1.17 raeburn 3328: &parse_webct4_questionDB($docroot,$$resources{$res}{file},$catinfo,$qzdbsettings,\%alldbanswers,\%alldbchoices,\@alldbquestids);
1.35 raeburn 3329: &build_category_sequences($destdir,$catinfo,$sequencesfiles,$pagesfiles,$destresdir,$newdir,$cms,$total,$randompickflag,$context,$udom,$uname,$dirname,$cid,$cdom,$cnum,$qzdbsettings);
3330: &write_webct4_questions($cms,\@alldbquestids,$context,$qzdbsettings,$dirname,\%alldbanswers,\%alldbchoices,$total,$cid,$cdom,$cnum,$destdir,$catinfo);
1.15 raeburn 3331: $$dbparse = 1;
3332: }
1.16 raeburn 3333: &parse_webct4_assessment($res,$docroot,$$resources{$res}{file},$container,\@allids);
1.18 raeburn 3334: &parse_webct4_quizprops($res,$docroot,$$hrefs{$$items{$$resources{$res}{revitm}}{properties}}[0],$container,\%qzparams);
3335: if (exists($qzparams{$res}{numpick})) {
3336: if ($qzparams{$res}{numpick} < @allids) {
3337: $$randompicks{$$resources{$res}{revitm}} = $qzparams{$res}{numpick};
3338: $randompickflag = 1;
1.15 raeburn 3339: }
3340: }
1.35 raeburn 3341: } elsif ($cms eq 'webctvista4') {
3342: unless($$dbparse) {
3343: foreach my $res (sort keys %{$allquestions}) {
3344: my $parent = $$allquestions{$res};
1.40 raeburn 3345: &parse_webctvista4_question($res,$docroot,$resources,$hrefs,$qzdbsettings,\@allquestids,\%allanswers,\%allchoices,$parent,$catinfo);
1.35 raeburn 3346: }
3347: &build_category_sequences($destdir,$catinfo,$sequencesfiles,$pagesfiles,$destresdir,$newdir,$cms,$total,$randompickflag,$context,$udom,$uname,$dirname,$cid,$cdom,$cnum,$qzdbsettings);
3348: $$dbparse = 1;
3349: }
1.40 raeburn 3350: &parse_webctvista4_assessment($res,$docroot,$$resources{$res}{file},\@allids,\%qzparams);
1.35 raeburn 3351: if ($qzparams{$res}{numpick} < @allids) {
3352: $$randompicks{$$resources{$res}{revitm}} = $qzparams{$res}{numpick};
3353: $randompickflag = 1;
3354: }
1.15 raeburn 3355: }
1.16 raeburn 3356: my $dirtitle;
1.40 raeburn 3357: unless ($cms eq 'webctce4' || $cms eq 'webctvista4') {
1.16 raeburn 3358: $dirtitle = $$settings{'title'};
1.40 raeburn 3359: $dirtitle =~ s/\s+/_/g;
3360: $dirtitle =~ s/:/_/g;
1.16 raeburn 3361: $dirtitle .= '_'.$res;
3362: if (!-e "$destdir/problems") {
3363: mkdir("$destdir/problems",0755);
3364: }
3365: if (!-e "$destdir/problems/$dirtitle") {
3366: mkdir("$destdir/problems/$dirtitle",0755);
3367: }
1.20 raeburn 3368: $newdir = "$destdir/problems/$dirtitle";
1.11 raeburn 3369: }
1.15 raeburn 3370:
1.34 raeburn 3371: if ($cms eq 'webctce4') {
1.44 raeburn 3372: if (@allids > 0 && $allids[0] ne '') {
3373: &build_problem_container($cms,$dirtitle,$destdir,$container,$res,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,\@allids,$udom,$uname,$dirname,\$containerdir,$cid,$cdom,$cnum,$catinfo,$qzdbsettings);
3374: }
1.20 raeburn 3375: } else {
1.40 raeburn 3376: &build_problem_container($cms,$dirtitle,$destdir,$container,$res,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,\@allids,$udom,$uname,$dirname,\$containerdir,$cid,$cdom,$cnum,$catinfo,$qzdbsettings,\%qzparams);
1.20 raeburn 3377: }
1.15 raeburn 3378: if ($cms eq 'bb5') {
1.20 raeburn 3379: &write_bb5_questions(\@allids,$containerdir,$context,$settings,$dirname,$destdir,$res,\%allanswers,\%allchoices,$total,$newdir,$cid,$cdom,$cnum,$docroot);
1.15 raeburn 3380: } elsif ($cms eq 'bb6') {
1.30 raeburn 3381: &write_bb6_questions(\@allids,$containerdir,$context,$settings,$dirname,$destdir,$res,$total,$newdir,$cid,$cdom,$cnum,$docroot);
1.35 raeburn 3382: } elsif ($cms eq 'webctvista4') {
1.40 raeburn 3383: &write_webct4_questions($cms,\@allquestids,$context,$qzdbsettings,$dirname,\%allanswers,\%allchoices,$total,$cid,$cdom,$cnum,$destdir,$catinfo,$dirtitle);
1.15 raeburn 3384: }
3385: }
3386:
1.35 raeburn 3387: sub build_category_sequences {
3388: my ($destdir,$catinfo,$sequencesfiles,$pagesfiles,$destresdir,$newdir,$cms,$total,$randompickflag,$context,$udom,$uname,$dirname,$cid,$cdom,$cnum,$qzdbsettings) = @_;
3389: if (!-e "$destdir/sequences") {
3390: mkdir("$destdir/sequences",0755);
3391: }
3392: my $numcats = scalar(keys %{$catinfo});
3393: my $curr_id = 0;
3394: my $next_id = 1;
3395: my $fh;
3396: open($fh,">$destdir/sequences/question_database.sequence");
3397: push @{$sequencesfiles},'question_database.sequence';
3398: foreach my $category (sort keys %{$catinfo}) {
1.40 raeburn 3399: my $seqname;
1.41 raeburn 3400: if ($cms eq 'webctce4') {
1.40 raeburn 3401: $seqname = $$catinfo{$category}{title}.'_'.$category;
3402: } else {
3403: $seqname = $$catinfo{$category}{title};
3404: }
3405: $seqname =~ s/\s+/_/g;
3406: $seqname =~ s/:/_/g;
1.35 raeburn 3407: push(@{$sequencesfiles},$seqname.'.sequence');
3408: my $catsrc = "$destresdir/sequences/$seqname.sequence";
3409: if ($curr_id == 0) {
3410: print $fh qq|<resource id="1" src="$catsrc" type="start" title="$$catinfo{$category}{title}"></resource>|;
3411: }
3412: if ($numcats == 1) {
3413: print $fh qq|
3414: <link from="1" to="2" index="1"></link>
3415: <resource id="2" src="" type="finish">\n|;
3416: } else {
3417: $curr_id = $next_id;
3418: $next_id = $curr_id + 1;
3419: $catsrc = "$destresdir/sequences/$seqname.sequence";
3420: print $fh qq|
3421: <link from="$curr_id" to="$next_id" index="$curr_id"></link>
3422: <resource id="$next_id" src="$catsrc" title="$$catinfo{$category}{title}"|;
3423: if ($next_id == $numcats) {
3424: print $fh qq| type="finish"></resource>\n|;
3425: } else {
3426: print $fh qq|></resource>\n|;
3427: }
3428: }
3429: print $fh qq|</map>|;
3430: if (!-e "$destdir/problems") {
3431: mkdir("$destdir/problems",0755);
3432: }
3433: if (!-e "$destdir/problems/$seqname") {
3434: mkdir("$destdir/problems/$seqname",0755);
3435: }
3436: $$newdir = "$destdir/problems/$seqname";
3437: my $dbcontainerdir;
3438: &build_problem_container($cms,$seqname,$destdir,'database',$seqname,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,\@{$$catinfo{$category}{contents}},$udom,$uname,$dirname,\$dbcontainerdir,$cid,$cdom,$cnum,$catinfo,$qzdbsettings);
3439: }
3440: close($fh);
3441: }
3442:
1.15 raeburn 3443: sub build_problem_container {
1.40 raeburn 3444: my ($cms,$dirtitle,$destdir,$container,$res,$total,$sequencesfiles,$pagesfiles,$randompickflag,$context,$allids,$udom,$uname,$dirname,$containerdir,$cid,$cdom,$cnum,$catinfo,$settings,$qzparams) = @_;
1.11 raeburn 3445: my $seqdir = "$destdir/sequences";
1.2 raeburn 3446: my $pagedir = "$destdir/pages";
3447: my $curr_id = 0;
3448: my $next_id = 1;
1.11 raeburn 3449: my $fh;
1.40 raeburn 3450: my $mapname = $res;
3451: if ($cms eq 'webctvista4' && ref($$qzparams{$res}) eq 'HASH') {
3452: if ($$qzparams{$res}{title}) {
3453: $mapname = $$qzparams{$res}{title};
3454: $mapname =~ s/\s+/_/g;
3455: }
3456: }
1.15 raeburn 3457: if ($container eq 'pool' || $randompickflag || $container eq 'database') {
1.40 raeburn 3458: $$containerdir = $seqdir.'/'.$mapname.'.sequence';
1.11 raeburn 3459: if (!-e "$seqdir") {
3460: mkdir("$seqdir",0770);
3461: }
1.15 raeburn 3462: open($fh,">$$containerdir");
1.11 raeburn 3463: $$total{seq} ++;
1.40 raeburn 3464: push @{$sequencesfiles},$mapname.'.sequence';
1.11 raeburn 3465: } else {
1.40 raeburn 3466: $$containerdir = $pagedir.'/'.$mapname.'.page';
1.50 raeburn 3467: if (!-e "$pagedir") {
3468: mkdir("$pagedir",0770);
1.11 raeburn 3469: }
1.15 raeburn 3470: open($fh,">$$containerdir");
1.11 raeburn 3471: $$total{page} ++;
1.40 raeburn 3472: push @{$pagesfiles},$mapname.'.page';
1.11 raeburn 3473: }
3474: print $fh qq|<map>
3475: |;
1.17 raeburn 3476: my %probtitle = ();
1.12 raeburn 3477: my $probsrc = "/res/lib/templates/simpleproblem.problem";
3478: if ($context eq 'CSTR') {
1.17 raeburn 3479: foreach my $id (@{$allids}) {
1.35 raeburn 3480: if (($cms eq 'webctce4') || ($cms eq 'webctvista4')) {
1.20 raeburn 3481: $probtitle{$id} = $$settings{$id}{title};
3482: } else {
3483: $probtitle{$id} = $$settings{title};
3484: }
1.40 raeburn 3485: $probtitle{$id} =~ s/\s+/_/g;
3486: $probtitle{$id} =~ s/:/_/g;
1.44 raeburn 3487: $probtitle{$id} =~ s/\//_/g;
1.53 ! raeburn 3488: if ($cms eq 'webctce4') {
! 3489: $probtitle{$id} .= '_'.$id;
! 3490: }
1.17 raeburn 3491: }
1.41 raeburn 3492: if (($cms eq 'webctce4' && $container ne 'database') ||
1.40 raeburn 3493: ($cms eq 'webctvista4')) {
3494: my $probdir;
1.16 raeburn 3495: my $catid = $$settings{$$allids[0]}{category};
1.40 raeburn 3496: if ($catid) {
1.41 raeburn 3497: if ($cms eq 'webctce4') {
1.40 raeburn 3498: $probdir = $$catinfo{$catid}{title}.'_'.$catid;
3499: } else {
3500: $probdir = $$catinfo{$catid}{title};
3501: }
3502: $probdir =~ s/\s+/_/g;
3503: $probdir =~ s/:/_/g;
3504: $probsrc = "$dirname/problems/$probdir/$probtitle{$$allids[0]}.problem";
3505: } else {
3506: $probsrc="$dirname/problems/$dirtitle/$probtitle{$$allids[0]}.problem";
3507: }
1.16 raeburn 3508: } else {
1.20 raeburn 3509: $probsrc="$dirname/problems/$dirtitle/$probtitle{$$allids[0]}.problem";
1.16 raeburn 3510: }
1.12 raeburn 3511: }
1.11 raeburn 3512: print $fh qq|<resource id="1" src="$probsrc" type="start" title="question_0001"></resource>|;
1.15 raeburn 3513: if (@{$allids} == 1) {
1.11 raeburn 3514: print $fh qq|
1.2 raeburn 3515: <link from="1" to="2" index="1"></link>
3516: <resource id="2" src="" type="finish">\n|;
1.11 raeburn 3517: } else {
1.15 raeburn 3518: for (my $j=1; $j<@{$allids}; $j++) {
3519: my $qntitle = $j+1;
1.11 raeburn 3520: while (length($qntitle) <4) {
3521: $qntitle = '0'.$qntitle;
3522: }
3523: $curr_id = $j;
3524: $next_id = $curr_id + 1;
3525: if ($context eq 'CSTR') {
1.40 raeburn 3526: if (($cms eq 'webctce4' && $container ne 'database') ||
3527: ($cms eq 'webctvista4')) {
3528: my $probdir;
1.16 raeburn 3529: my $catid = $$settings{$$allids[$j]}{category};
1.40 raeburn 3530: if ($catid) {
1.41 raeburn 3531: if ($cms eq 'webctce4') {
1.40 raeburn 3532: $probdir = $$catinfo{$catid}{title}.'_'.$catid;
3533: } else {
3534: $probdir = $$catinfo{$catid}{title};
3535: }
3536: $probdir =~ s/\s/_/g;
3537: $probdir =~ s/:/_/g;
3538: $probsrc = "$dirname/problems/$probdir/$probtitle{$$allids[$j]}.problem";
3539: } else {
3540: $probsrc = "$dirname/problems/$dirtitle/$probtitle{$$allids[$j]}.problem";
3541: }
1.16 raeburn 3542: } else {
1.20 raeburn 3543: $probsrc = "$dirname/problems/$dirtitle/$probtitle{$$allids[$j]}.problem";
1.16 raeburn 3544: }
1.11 raeburn 3545: }
3546: print $fh qq|
1.2 raeburn 3547: <link from="$curr_id" to="$next_id" index="$curr_id"></link>
1.11 raeburn 3548: <resource id="$next_id" src="$probsrc" title="question_$qntitle"|;
1.15 raeburn 3549: if ($next_id == @{$allids}) {
1.11 raeburn 3550: print $fh qq| type="finish"></resource>\n|;
3551: } else {
3552: print $fh qq|></resource>|;
1.2 raeburn 3553: }
3554: }
3555: }
1.11 raeburn 3556: print $fh qq|</map>|;
3557: close($fh);
1.15 raeburn 3558: }
3559:
3560: sub write_bb5_questions {
1.20 raeburn 3561: my ($allids,$containerdir,$context,$settings,$dirname,$destdir,$res,$allanswers,$allchoices,$total,$newdir,$cid,$cdom,$cnum,$docroot) = @_;
1.12 raeburn 3562: my $qnum = 0;
1.33 raeburn 3563: my $pathstart;
1.50 raeburn 3564: my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
1.33 raeburn 3565: if ($context eq 'CSTR') {
3566: $pathstart = '../..';
3567: } else {
3568: $pathstart = $dirname;
3569: }
1.15 raeburn 3570: foreach my $id (@{$allids}) {
1.20 raeburn 3571: if ($$settings{$id}{ishtml} eq 'true') {
3572: $$settings{$id}{text} = &HTML::Entities::decode($$settings{$id}{text});
3573: }
3574: if ($$settings{$id}{text} =~ m#<img src=['"]?(https?://[^\s]+/)([^/\s\'"]+)['"]?[^>]*>#) {
3575: if (&retrieve_image($context,$res,$dirname,$cdom,$cnum,$docroot,$destdir,$1,$2) eq 'ok') {
1.33 raeburn 3576: $$settings{$id}{text} =~ s#(<img src=['"]?)(https?://[^\s]+/)([^/\s'"]+)(['"]?[^>]*>)#$1$pathstart/resfiles/$res/webimages/$3$4#g;
1.20 raeburn 3577: }
3578: }
3579: $$settings{$id}{text} =~ s#(<img src=[^>]+)/*>#$1 />#gi;
3580: $$settings{$id}{text} =~ s#<br>#<br />#g;
1.12 raeburn 3581: $qnum ++;
1.11 raeburn 3582: my $output;
1.12 raeburn 3583: my $permcontainer = $containerdir;
1.50 raeburn 3584: $permcontainer =~ s{^\Q$londocroot/userfiles\E}{uploaded};
1.12 raeburn 3585: my $symb = $cid.'.'.$permcontainer.'___'.$qnum.'___lib/templates/simpleproblem.problem.0.';
3586: my %resourcedata = ();
3587: for (my $i=0; $i<10; $i++) {
3588: my $iter = $i+1;
3589: $resourcedata{$symb.'text'.$iter} = "";
3590: $resourcedata{$symb.'value'.$iter} = "unused";
3591: $resourcedata{$symb.'position'.$iter} = "random";
1.15 raeburn 3592: }
1.12 raeburn 3593: $resourcedata{$symb.'randomize'} = 'yes';
3594: $resourcedata{$symb.'maxfoils'} = 10;
1.11 raeburn 3595: if ($context eq 'CSTR') {
3596: $output = qq|<problem>
1.2 raeburn 3597: |;
1.11 raeburn 3598: }
1.3 raeburn 3599: $$total{prob} ++;
1.2 raeburn 3600: if ($$settings{$id}{class} eq "QUESTION_ESSAY") {
1.11 raeburn 3601: if ($context eq 'CSTR') {
3602: $output .= qq|<startouttext />$$settings{$id}{text}<endouttext />
1.2 raeburn 3603: <essayresponse>
3604: <textfield></textfield>
3605: </essayresponse>
3606: <postanswerdate>
1.15 raeburn 3607: $$settings{$id}{feedbackcorr}
1.2 raeburn 3608: </postanswerdate>
3609: |;
1.12 raeburn 3610: } else {
3611: $resourcedata{$symb.'questiontext'} = $$settings{$id}{text};
3612: $resourcedata{$symb.'hiddenparts'} = '!essay';
3613: $resourcedata{$symb.'questiontype'} = 'essay';
1.11 raeburn 3614: }
1.2 raeburn 3615: } else {
1.11 raeburn 3616: if ($context eq 'CSTR') {
3617: $output .= qq|<startouttext />$$settings{$id}{text}\n|;
1.12 raeburn 3618: } else {
3619: $resourcedata{$symb.'questiontext'} = $$settings{$id}{text};
1.11 raeburn 3620: }
3621: my ($image,$imglink,$url);
3622: if ( defined($$settings{$id}{image}) ) {
1.2 raeburn 3623: if ( $$settings{$id}{style} eq 'embed' ) {
1.33 raeburn 3624: $image = qq|<br /><img src="$pathstart/resfiles/$res/$$settings{$id}{image}" /><br />|;
1.2 raeburn 3625: } else {
1.33 raeburn 3626: $imglink = qq|<br /><a href="$pathstart/resfiles/$res/$$settings{$id}{image}">Link to file</a><br />|;
1.2 raeburn 3627: }
3628: }
3629: if ( defined($$settings{$id}{url}) ) {
1.11 raeburn 3630: $url = qq|<br /><a href="$$settings{$id}{url}">$$settings{$id}{name}</a><br />|;
3631: }
3632: if ($context eq 'CSTR') {
3633: $output .= $image.$imglink.$url.'
3634: <endouttext />';
1.12 raeburn 3635: } else {
3636: $resourcedata{$symb.'questiontext'} .= $image.$imglink.$url;
1.2 raeburn 3637: }
3638: if ($$settings{$id}{class} eq 'QUESTION_MULTIPLECHOICE') {
1.15 raeburn 3639: my $numfoils = @{$$allanswers{$id}};
1.11 raeburn 3640: if ($context eq 'CSTR') {
3641: $output .= qq|
1.2 raeburn 3642: <radiobuttonresponse max="$numfoils" randomize="yes">
3643: <foilgroup>
3644: |;
1.12 raeburn 3645: } else {
3646: $resourcedata{$symb.'hiddenparts'} = '!radio';
3647: $resourcedata{$symb.'questiontype'} = 'radio';
3648: $resourcedata{$symb.'maxfoils'} = $numfoils;
1.11 raeburn 3649: }
1.15 raeburn 3650: for (my $k=0; $k<@{$$allanswers{$id}}; $k++) {
1.12 raeburn 3651: my $iter = $k+1;
1.2 raeburn 3652: $output .= " <foil name=\"foil".$k."\" value=\"";
1.15 raeburn 3653: if (grep/^$$allanswers{$id}[$k]$/,@{$$settings{$id}{correctanswer}}) {
1.2 raeburn 3654: $output .= "true\" location=\"";
1.12 raeburn 3655: $resourcedata{$symb.'value'.$iter} = "true";
1.2 raeburn 3656: } else {
3657: $output .= "false\" location=\"";
1.12 raeburn 3658: $resourcedata{$symb.'value'.$iter} = "false";
1.2 raeburn 3659: }
1.16 raeburn 3660: if (lc ($$allanswers{$id}[$k]) =~ m/^\s?([Aa]ll)|([Nn]one)\s(of\s)?the\sabove\.?/) {
1.2 raeburn 3661: $output .= "bottom\"";
1.12 raeburn 3662: $resourcedata{$symb.'position'.$iter} = "bottom";
1.2 raeburn 3663: } else {
3664: $output .= "random\"";
3665: }
1.15 raeburn 3666: $output .= "\><startouttext />".$$settings{$id}{$$allanswers{$id}[$k]}{text};
3667: $resourcedata{$symb.'text'.$iter} = $$settings{$id}{$$allanswers{$id}[$k]}{text};
1.11 raeburn 3668: my ($ans_image,$ans_link);
1.15 raeburn 3669: if ( defined($$settings{$id}{$$allanswers{$id}[$k]}{image}) ) {
3670: if ( $$settings{$id}{$$allanswers{$id}[$k]}{style} eq 'embed' ) {
1.33 raeburn 3671: $ans_image .= qq|<br /><img src="$pathstart/resfiles/$res/$$settings{$id}{$$allanswers{$id}[$k]}{image}" /><br />|;
1.2 raeburn 3672: } else {
1.33 raeburn 3673: $ans_link .= qq|<br /><a href="$pathstart/resfiles/$res/$$settings{$id}{$$allanswers{$id}[$k]}{image}" />Link to file</a><br/>|;
1.2 raeburn 3674: }
3675: }
1.11 raeburn 3676: $output .= $ans_image.$ans_link.'<endouttext /></foil>'."\n";
1.12 raeburn 3677: $resourcedata{$symb.'text'.$iter} .= $ans_image.$ans_link;
1.2 raeburn 3678: }
1.11 raeburn 3679: if ($context eq 'CSTR') {
3680: chomp($output);
3681: $output .= qq|
1.2 raeburn 3682: </foilgroup>
3683: </radiobuttonresponse>
3684: |;
1.11 raeburn 3685: }
1.2 raeburn 3686: } elsif ($$settings{$id}{class} eq 'QUESTION_TRUEFALSE') {
1.15 raeburn 3687: my $numfoils = @{$$allanswers{$id}};
1.11 raeburn 3688: if ($context eq 'CSTR') {
3689: $output .= qq|
1.2 raeburn 3690: <radiobuttonresponse max="$numfoils" randomize="yes">
3691: <foilgroup>
3692: |;
1.12 raeburn 3693: } else {
3694: $resourcedata{$symb.'maxfoils'} = $numfoils;
3695: $resourcedata{$symb.'hiddenparts'} = '!radio';
3696: $resourcedata{$symb.'questiontype'} = 'radio';
1.11 raeburn 3697: }
1.15 raeburn 3698: for (my $k=0; $k<@{$$allanswers{$id}}; $k++) {
1.12 raeburn 3699: my $iter = $k+1;
1.2 raeburn 3700: $output .= " <foil name=\"foil".$k."\" value=\"";
1.15 raeburn 3701: if (grep/^$$allanswers{$id}[$k]$/,@{$$settings{$id}{correctanswer}}) {
1.2 raeburn 3702: $output .= "true\" location=\"random\"";
1.12 raeburn 3703: $resourcedata{$symb.'value'.$iter} = "true";
1.2 raeburn 3704: } else {
3705: $output .= "false\" location=\"random\"";
1.12 raeburn 3706: $resourcedata{$symb.'value'.$iter} = "false";
1.2 raeburn 3707: }
1.15 raeburn 3708: $output .= "\><startouttext />".$$settings{$id}{$$allanswers{$id}[$k]}{text}."<endouttext /></foil>\n";
3709: $resourcedata{$symb.'text'.$iter} = $$settings{$id}{$$allanswers{$id}[$k]}{text};
1.2 raeburn 3710: }
1.11 raeburn 3711: if ($context eq 'CSTR') {
3712: chomp($output);
3713: $output .= qq|
1.2 raeburn 3714: </foilgroup>
3715: </radiobuttonresponse>
3716: |;
1.11 raeburn 3717: }
1.2 raeburn 3718: } elsif ($$settings{$id}{class} eq 'QUESTION_MULTIPLEANSWER') {
1.15 raeburn 3719: my $numfoils = @{$$allanswers{$id}};
1.11 raeburn 3720: if ($context eq 'CSTR') {
3721: $output .= qq|
1.2 raeburn 3722: <optionresponse max="$numfoils" randomize="yes">
3723: <foilgroup options="('True','False')">
3724: |;
1.12 raeburn 3725: } else {
3726: $resourcedata{$symb.'newopt'} = '';
3727: $resourcedata{$symb.'delopt'} = '';
3728: $resourcedata{$symb.'options'} = "('True','False')";
3729: $resourcedata{$symb.'hiddenparts'} = '!option';
3730: $resourcedata{$symb.'questiontype'} = 'option';
3731: $resourcedata{$symb.'maxfoils'} = $numfoils;
1.11 raeburn 3732: }
1.15 raeburn 3733: for (my $k=0; $k<@{$$allanswers{$id}}; $k++) {
1.12 raeburn 3734: my $iter = $k+1;
1.2 raeburn 3735: $output .= " <foil name=\"foil".$k."\" value=\"";
1.15 raeburn 3736: if (grep/^$$allanswers{$id}[$k]$/,@{$$settings{$id}{correctanswer}}) {
1.2 raeburn 3737: $output .= "True\"";
1.12 raeburn 3738: $resourcedata{$symb.'value'.$iter} = "True";
1.2 raeburn 3739: } else {
3740: $output .= "False\"";
1.12 raeburn 3741: $resourcedata{$symb.'value'.$iter} = "False";
1.2 raeburn 3742: }
1.15 raeburn 3743: $output .= "\><startouttext />".$$settings{$id}{$$allanswers{$id}[$k]}{text}."<endouttext /></foil>\n";
3744: $resourcedata{$symb.'text'.$iter} = $$settings{$id}{$$allanswers{$id}[$k]}{text};
1.2 raeburn 3745: }
1.11 raeburn 3746: if ($context eq 'CSTR') {
3747: chomp($output);
3748: $output .= qq|
1.2 raeburn 3749: </foilgroup>
3750: </optionresponse>
3751: |;
1.11 raeburn 3752: }
1.2 raeburn 3753: } elsif ($$settings{$id}{class} eq 'QUESTION_ORDER') {
1.15 raeburn 3754: my $numfoils = @{$$allanswers{$id}};
1.12 raeburn 3755: my @allorder = ();
1.11 raeburn 3756: if ($context eq 'CSTR') {
3757: $output .= qq|
1.2 raeburn 3758: <rankresponse max="$numfoils" randomize="yes">
3759: <foilgroup>
3760: |;
1.12 raeburn 3761: } else {
3762: $resourcedata{$symb.'newopt'} = '';
3763: $resourcedata{$symb.'delopt'} = '';
3764: $resourcedata{$symb.'hiddenparts'} = '!option';
3765: $resourcedata{$symb.'questiontype'} = 'option';
3766: $resourcedata{$symb.'maxfoils'} = $numfoils;
1.11 raeburn 3767: }
1.15 raeburn 3768: for (my $k=0; $k<@{$$allanswers{$id}}; $k++) {
1.11 raeburn 3769: if ($context eq 'CSTR') {
1.15 raeburn 3770: $output .= " <foil location=\"random\" name=\"foil".$k."\" value=\"".$$settings{$id}{$$allanswers{$id}[$k]}{order}."\"><startouttext />".$$settings{$id}{$$allanswers{$id}[$k]}{text}."<endouttext /></foil>\n";
1.12 raeburn 3771: } else {
3772: my $iter = $k+1;
1.15 raeburn 3773: $resourcedata{$symb.'text'.$iter} = $$settings{$id}{$$allanswers{$id}[$k]}{text};
3774: if (!grep/^$$settings{$id}{$$allanswers{$id}[$k]}{order}$/,@allorder) {
3775: push @allorder, $$settings{$id}{$$allanswers{$id}[$k]}{order};
1.12 raeburn 3776: }
1.11 raeburn 3777: }
1.2 raeburn 3778: }
1.11 raeburn 3779: if ($context eq 'CSTR') {
3780: chomp($output);
3781: $output .= qq|
1.2 raeburn 3782: </foilgroup>
3783: </rankresponse>
3784: |;
1.12 raeburn 3785: } else {
3786: @allorder = sort {$a <=> $b} @allorder;
3787: $resourcedata{$symb.'options'} = "('".join("','",@allorder)."')";
1.11 raeburn 3788: }
1.2 raeburn 3789: } elsif ($$settings{$id}{class} eq 'QUESTION_FILLINBLANK') {
3790: my $numerical = 1;
1.11 raeburn 3791: if ($context eq 'DOCS') {
3792: $numerical = 0;
3793: } else {
1.15 raeburn 3794: for (my $k=0; $k<@{$$allanswers{$id}}; $k++) {
3795: if ($$settings{$id}{$$allanswers{$id}[$k]}{text} =~ m/([^\d\.]|\.\.)/) {
1.11 raeburn 3796: $numerical = 0;
3797: }
1.2 raeburn 3798: }
3799: }
3800: if ($numerical) {
3801: my $numans;
3802: my $tol;
1.15 raeburn 3803: if (@{$$allanswers{$id}} == 1) {
1.2 raeburn 3804: $tol = 5;
1.15 raeburn 3805: $numans = $$settings{$id}{$$allanswers{$id}[0]}{text};
1.2 raeburn 3806: } else {
1.15 raeburn 3807: my $min = $$settings{$id}{$$allanswers{$id}[0]}{text};
3808: my $max = $$settings{$id}{$$allanswers{$id}[0]}{text};
3809: for (my $k=1; $k<@{$$allanswers{$id}}; $k++) {
3810: if ($$settings{$id}{$$allanswers{$id}[$k]}{text} <= $min) {
3811: $min = $$settings{$id}{$$allanswers{$id}[$k]}{text};
1.2 raeburn 3812: }
1.15 raeburn 3813: if ($$settings{$id}{$$allanswers{$id}[$k]}{text} >= $max) {
3814: $max = $$settings{$id}{$$allanswers{$id}[$k]}{text};
1.2 raeburn 3815: }
3816: }
3817: $numans = ($max + $min)/2;
3818: $tol = 100*($max - $min)/($numans*2);
3819: }
1.11 raeburn 3820: if ($context eq 'CSTR') {
3821: $output .= qq|
1.2 raeburn 3822: <numericalresponse answer="$numans">
3823: <responseparam type="tolerance" default="$tol%" name="tol" description="Numerical Tolerance" />
3824: <responseparam name="sig" type="int_range,0-16" default="0,15" description="Significant Figures"
3825: />
3826: <textline />
3827: </numericalresponse>
3828: |;
1.11 raeburn 3829: }
1.2 raeburn 3830: } else {
1.12 raeburn 3831: if ($context eq 'DOCS') {
3832: $resourcedata{$symb.'hiddenparts'} = '!string';
3833: $resourcedata{$symb.'questiontype'} = 'string';
1.15 raeburn 3834: $resourcedata{$symb.'maxfoils'} = @{$$allanswers{$id}};
1.12 raeburn 3835: $resourcedata{$symb.'hiddenparts'} = '!string';
3836: $resourcedata{$symb.'stringtype'} = 'ci';
1.15 raeburn 3837: $resourcedata{$symb.'stringanswer'} = $$settings{$id}{$$allanswers{$id}[0]}{text};
1.12 raeburn 3838: } else {
1.15 raeburn 3839: if (@{$$allanswers{$id}} == 1) {
1.11 raeburn 3840: $output .= qq|
1.15 raeburn 3841: <stringresponse answer="$$settings{$id}{$$allanswers{$id}[0]}{text}" type="ci">
1.2 raeburn 3842: <textline>
3843: </textline>
3844: </stringresponse>
3845: |;
1.11 raeburn 3846: } else {
3847: my @answertext = ();
1.15 raeburn 3848: for (my $k=0; $k<@{$$allanswers{$id}}; $k++) {
3849: $$settings{$id}{$$allanswers{$id}[$k]}{text} =~ s/\|/\|/g;
3850: push @answertext, $$settings{$id}{$$allanswers{$id}[$k]}{text};
1.11 raeburn 3851: }
3852: my $regexpans = join('|',@answertext);
3853: $regexpans = '/^('.$regexpans.')\b/';
3854: $output .= qq|
1.2 raeburn 3855: <stringresponse answer="$regexpans" type="re">
3856: <textline>
3857: </textline>
3858: </stringresponse>
3859: |;
1.11 raeburn 3860: }
3861: }
1.2 raeburn 3862: }
3863: } elsif ($$settings{$id}{class} eq "QUESTION_MATCH") {
1.12 raeburn 3864: my @allmatchers = ();
3865: my %matchtext = ();
1.11 raeburn 3866: if ($context eq 'CSTR') {
3867: $output .= qq|
1.2 raeburn 3868: <matchresponse max="10" randomize="yes">
3869: <foilgroup>
3870: <itemgroup>
3871: |;
1.12 raeburn 3872: } else {
3873: $resourcedata{$symb.'newopt'} = '';
3874: $resourcedata{$symb.'delopt'} = '';
3875: $resourcedata{$symb.'hiddenparts'} = '!option';
3876: $resourcedata{$symb.'questiontype'} = 'option';
1.15 raeburn 3877: $resourcedata{$symb.'maxfoils'} = @{$$allanswers{$id}};
1.11 raeburn 3878: }
1.15 raeburn 3879: for (my $k=0; $k<@{$$allchoices{$id}}; $k++) {
1.11 raeburn 3880: if ($context eq 'CSTR') {
3881: $output .= qq|
1.15 raeburn 3882: <item name="$$allchoices{$id}[$k]">
3883: <startouttext />$$settings{$id}{$$allchoices{$id}[$k]}{text}<endouttext />
1.2 raeburn 3884: </item>
3885: |;
1.12 raeburn 3886: } else {
1.15 raeburn 3887: if (!grep/^$$settings{$id}{$$allchoices{$id}[$k]}{text}$/,@allmatchers) {
3888: push @allmatchers, $$settings{$id}{$$allchoices{$id}[$k]}{text};
3889: $matchtext{$$allchoices{$id}[$k]} = $$settings{$id}{$$allchoices{$id}[$k]}{text};
1.12 raeburn 3890: }
1.11 raeburn 3891: }
1.2 raeburn 3892: }
1.11 raeburn 3893: if ($context eq 'CSTR') {
3894: $output .= qq|
1.2 raeburn 3895: </itemgroup>
3896: |;
1.11 raeburn 3897: }
1.15 raeburn 3898: for (my $k=0; $k<@{$$allanswers{$id}}; $k++) {
1.11 raeburn 3899: if ($context eq 'CSTR') {
3900: $output .= qq|
1.15 raeburn 3901: <foil location="random" value="$$settings{$id}{$$allanswers{$id}[$k]}{choice_id}" name="$$allanswers{$id}[$k]">
3902: <startouttext />$$settings{$id}{$$allanswers{$id}[$k]}{text}<endouttext />
1.2 raeburn 3903: </foil>
3904: |;
1.12 raeburn 3905: } else {
3906: my $iter = $k+1;
1.15 raeburn 3907: $resourcedata{$symb.'value'.$iter} = $matchtext{$$settings{$id}{$$allanswers{$id}[$k]}{choice_id}};
3908: $resourcedata{$symb.'text'.$iter} = $$settings{$id}{$$allanswers{$id}[$k]}{text};
1.11 raeburn 3909: }
1.2 raeburn 3910: }
1.11 raeburn 3911: if ($context eq 'CSTR') {
3912: $output .= qq|
1.2 raeburn 3913: </foilgroup>
3914: </matchresponse>
3915: |;
1.12 raeburn 3916: } else {
3917: $resourcedata{$symb.'options'} = "('".join("','",@allmatchers)."')";
1.11 raeburn 3918: }
1.2 raeburn 3919: }
3920: }
1.11 raeburn 3921: if ($context eq 'CSTR') {
3922: $output .= qq|</problem>
1.2 raeburn 3923: |;
1.20 raeburn 3924: my $title = $$settings{title};
3925: $title =~ s/\s/_/g;
3926: $title =~ s/\W//g;
3927: $title .= '_'.$id;
1.39 raeburn 3928: open(PROB,">$newdir/$title.problem");
1.11 raeburn 3929: print PROB $output;
3930: close PROB;
1.12 raeburn 3931: } else {
3932: # put %resourcedata;
3933: my $reply=&Apache::lonnet::cput
3934: ('resourcedata',\%resourcedata,$cdom,$cnum);
1.11 raeburn 3935: }
1.2 raeburn 3936: }
3937: }
3938:
1.15 raeburn 3939: sub write_webct4_questions {
1.40 raeburn 3940: my ($cms,$alldbquestids,$context,$settings,$dirname,$allanswers,$allchoices,$total,$cid,$cdom,$cnum,$destdir,$catinfo,$dirtitle) = @_;
1.50 raeburn 3941: my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
1.16 raeburn 3942: my $qnum = 0;
3943: foreach my $id (@{$alldbquestids}) {
3944: $qnum ++;
3945: my $output;
3946: my $permcontainer = $destdir.'/sequences/'.$id.'.sequence';
3947: my $allfeedback;
3948: my $questionimage;
3949: foreach my $fdbk (@{$$settings{$id}{feedback}}) {
3950: my $feedback = $$settings{$id}{$fdbk}{text};
1.44 raeburn 3951: if ($feedback ne '') {
3952: if ($$settings{$id}{$fdbk}{texttype} eq 'text/html') {
3953: $feedback = &HTML::Entities::decode($feedback);
3954: }
3955: $allfeedback .= $feedback;
1.16 raeburn 3956: }
3957: }
3958: if ($$settings{$id}{texttype} eq 'text/html') {
1.35 raeburn 3959: if ($$settings{$id}{text}) {
3960: $$settings{$id}{text} = &text_cleanup($$settings{$id}{text});
3961: }
3962: }
1.16 raeburn 3963: if ($$settings{$id}{class} eq 'numerical') {
3964: foreach my $numid (@{$$settings{$id}{numids}}) {
3965: foreach my $var (keys %{$$settings{$id}{$numid}{vars}}) {
1.41 raeburn 3966: if ($cms eq 'webctce4') {
1.35 raeburn 3967: $$settings{$id}{text} =~ s/{($var)}/\$$1 /g;
3968: } elsif ($cms eq 'webctvista4') {
3969: $$settings{$id}{text} =~ s/\[($var)\]/\$$1 /g;
3970: }
1.16 raeburn 3971: }
3972: }
3973: }
1.50 raeburn 3974: $permcontainer =~ s{\Q$londocroot/userfiles\E}{uploaded};
1.16 raeburn 3975: my $symb = $cid.'.'.$permcontainer.'___'.$qnum.'___lib/templates/simpleproblem.problem.0.';
3976: my %resourcedata = ();
3977: for (my $i=0; $i<10; $i++) {
3978: my $iter = $i+1;
3979: $resourcedata{$symb.'text'.$iter} = "";
3980: $resourcedata{$symb.'value'.$iter} = "unused";
3981: $resourcedata{$symb.'position'.$iter} = "random";
3982: }
3983: $resourcedata{$symb.'randomize'} = 'yes';
3984: $resourcedata{$symb.'maxfoils'} = 10;
3985: if ($context eq 'CSTR') {
1.22 raeburn 3986: unless ($$settings{$id}{class} eq 'numerical') {
3987: $output = qq|<problem>
1.16 raeburn 3988: |;
1.22 raeburn 3989: }
1.16 raeburn 3990: }
3991: $$total{prob} ++;
1.41 raeburn 3992:
1.16 raeburn 3993: if (exists($$settings{$id}{uri})) {
1.41 raeburn 3994: if ($cms eq 'webctce4') {
1.35 raeburn 3995: if ($$settings{$id}{imagtype} =~ /^image\//) {
3996: $questionimage = '<p><img src="../../resfiles/'.$$settings{$id}{uri}.'" /></p>'."\n";
3997: } else {
3998: $questionimage = '<p><img src="../../resfiles/'.$$settings{$id}{uri}.'" /></p>'."\n";
3999: }
4000: } elsif ($cms eq 'webctvista4') {
4001: if ($$settings{$id}{uri} =~ /(gif|jpg|png)$/i) {
4002: $questionimage = '<p><img src="../../resfiles/'.$$settings{$id}{uri}.'" /></p>'."\n";
4003: $questionimage =~ s#(//+)#/#g;
4004: } else {
4005: $questionimage = '<a href="'.$$settings{$id}{uri}.'" target="exturi" >'.$$settings{$id}{uri}.'</a>';
4006: }
1.16 raeburn 4007: }
4008: }
1.52 raeburn 4009: if (($cms eq 'webctvista4') && (defined($$settings{$id}{image}))) {
4010: my $imgsrc = '../../resfiles/'.$$settings{$id}{image};
4011: if (defined($$settings{$id}{imagetitle})) {
1.53 ! raeburn 4012: $imgsrc = '../../resfiles/'.$$settings{$id}{imagetitle};
1.52 raeburn 4013: }
4014: $questionimage = qq|<p><img src="$imgsrc" /></p>|;
4015: }
1.16 raeburn 4016: if ($$settings{$id}{class} eq "paragraph") {
1.35 raeburn 4017: my $pre_fill_answer = $$settings{$id}{PARA}{PARA}{PRE_FILL_ANSWER};
1.16 raeburn 4018: if ($context eq 'CSTR') {
4019: $output .= qq|<startouttext /><p>$$settings{$id}{text}</p>$questionimage<endouttext />
4020: <essayresponse>
1.35 raeburn 4021: <textfield>$pre_fill_answer</textfield>
1.16 raeburn 4022: </essayresponse>
4023: |;
4024: } else {
4025: $resourcedata{$symb.'questiontext'} = '<p>'.$$settings{$id}{text}.'</p>'.$questionimage;
4026: $resourcedata{$symb.'hiddenparts'} = '!essay';
4027: $resourcedata{$symb.'questiontype'} = 'essay';
4028: }
1.37 raeburn 4029: } elsif ($$settings{$id}{class} eq 'jumbled') {
4030: if ($context eq 'CSTR') {
4031: my %foiloptions = ();
4032: foreach my $list (@{$$settings{$id}{lists}}) {
4033: @{$foiloptions{$list}} = ();
4034: my $numalternates = @{$$settings{$id}{$list}{jumbled}} - 1;
4035: my $loopstop = 2; #Hard coded for now, so only one permutation of answers is correct; <or> functionality is needed to support the case where multiple permutations are correct.
4036: for (my $i=1; $i<$loopstop; $i++) {
4037: $foiloptions{$list}[$i] = '(';
4038: for (my $j=@{$$settings{$id}{$list}{jumbled}[$i]}-1; $j>0; $j--) {
4039: my $jumble_item = $$settings{$id}{$list}{jumbled}[$i][$j];
4040: $foiloptions{$list}[$i] .= "'".$$settings{$id}{$list}{$jumble_item}{text}."',";
4041: }
4042: $foiloptions{$list}[$i] =~ s/,$//;
4043: $foiloptions{$list}[$i] .= ')';
4044: my $jnum = 0;
4045: for (my $k=0; $k<@{$$settings{$id}{$list}{jumbledtype}}; $k++) {
4046: if ($$settings{$id}{$list}{jumbledtype}[$k] eq 'No') {
4047: $output .= qq|
4048: <startouttext />
4049: $$settings{$id}{$list}{jumbledtext}[$k]
4050: <endouttext />|;
4051: } elsif ($$settings{$id}{$list}{jumbledtype}[$k] eq 'Yes') {
4052: $jnum ++;
4053: my $jumble_item = $$settings{$id}{$list}{jumbled}[$i][$jnum];
4054: $output .= qq|
4055: <optionresponse max="1" randomize="yes" TeXlayout="horizontal">
4056: <foilgroup options="$foiloptions{$list}[$i]">
4057: <foil location="random" value="$$settings{$id}{$list}{$jumble_item}{text}" name="$jumble_item"></foil>
4058: </foilgroup>
4059: </optionresponse>
4060: |;
4061: }
4062: }
4063: }
4064: if ($numalternates > 0) { # for now alternates are stored in an instructorcomment. In the future these alternates could be moved into the main response area once <or> functionality is available.
4065: $output .= '<instructorcomment>(Not shown to students) '."\n".'The following alternates were imported from the corresponding WebCT Vista 4 jumbled sentence question, but are not included in the LON-CAPA version, because this style of question does not currently support multiple correct solutions.'."\n";
4066: for (my $i=2; $i<@{$$settings{$id}{$list}{jumbled}}; $i++) {
4067: my $altid = $i-1;
4068: my $jnum = 0;
4069: $output .= $altid.'. ';
4070: for (my $k=0; $k<@{$$settings{$id}{$list}{jumbledtype}}; $k++) {
4071: if ($$settings{$id}{$list}{jumbledtype}[$k] eq 'No') {
4072: $output .= "$$settings{$id}{$list}{jumbledtext}[$k]" ;
4073: } elsif ($$settings{$id}{$list}{jumbledtype}[$k] eq 'Yes') {
4074: $jnum ++;
4075: my $jumble_item = $$settings{$id}{$list}{jumbled}[$i][$jnum];
4076: $output .= '['.$$settings{$id}{$list}{$jumble_item}{text}.']';
4077: }
4078: }
4079: $output .= " \n";
4080: }
4081: $output .= '</instructorcomment>';
4082: }
4083: }
4084: }
1.16 raeburn 4085: } else {
4086: if ($context eq 'CSTR') {
4087: $output .= qq|<startouttext /><p>$$settings{$id}{text}</p>$questionimage<endouttext />\n|;
4088: } else {
4089: $resourcedata{$symb.'questiontext'} = '<p>'.$$settings{$id}{text}.'</p>'.$questionimage;
4090: }
1.36 raeburn 4091: if (($$settings{$id}{class} eq 'multiplechoice') ||
4092: ($$settings{$id}{class} eq 'combination')) {
1.16 raeburn 4093: foreach my $list (@{$$settings{$id}{lists}}) {
4094: my $numfoils = @{$$allanswers{$id}{$list}};
4095: if ($$settings{$id}{$list}{rcardinality} eq 'Single') {
4096: if ($context eq 'CSTR') {
4097: $output .= qq|
4098: <radiobuttonresponse max="$numfoils" randomize="$$settings{$id}{$list}{randomize}">
4099: <foilgroup>
4100: |;
4101: } else {
4102: $resourcedata{$symb.'hiddenparts'} = '!radio';
4103: $resourcedata{$symb.'questiontype'} = 'radio';
4104: $resourcedata{$symb.'maxfoils'} = $numfoils;
4105: }
4106: for (my $k=0; $k<@{$$allanswers{$id}{$list}}; $k++) {
4107: my $iter = $k+1;
4108: $output .= " <foil name=\"foil".$k."\" value=\"";
4109: if (grep/^$$allanswers{$id}{$list}[$k]$/,@{$$settings{$id}{$list}{correctanswer}}) {
4110: $output .= "true\" location=\"";
4111: $resourcedata{$symb.'value'.$iter} = "true";
4112: } else {
4113: $output .= "false\" location=\"";
4114: $resourcedata{$symb.'value'.$iter} = "false";
4115: }
4116: if (lc ($$allanswers{$id}{$list}[$k]) =~ m/^\s?([Aa]ll)|([Nn]one)\s(of\s)?the\sabove\.?/) {
4117: $output .= "bottom\"";
4118: $resourcedata{$symb.'position'.$iter} = "bottom";
4119: } else {
4120: $output .= "random\"";
4121: }
4122: if ($$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{texttype} eq 'text/html') {
4123: $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text} = &HTML::Entities::decode($$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text});
1.21 www 4124: $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text} = &Apache::loncleanup::htmlclean($$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text});
1.16 raeburn 4125: $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text} =~ s#(<img src=")([^>]+)>#$1../../resfiles/$2 />#gi;
4126: $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text} =~ s#</?p>##g;
4127:
4128: }
4129: $output .= "\><startouttext />".$$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text};
4130: $resourcedata{$symb.'text'.$iter} = $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text};
4131: $output .= '<endouttext /></foil>'."\n";
4132: }
4133: if ($context eq 'CSTR') {
4134: chomp($output);
4135: $output .= qq|
4136: </foilgroup>
4137: </radiobuttonresponse>
4138: |;
4139: }
4140: } else {
4141: if ($context eq 'CSTR') {
4142: $output .= qq|
4143: <optionresponse max="$numfoils" randomize="yes">
4144: <foilgroup options="('True','False')">
4145: |;
4146: } else {
4147: $resourcedata{$symb.'newopt'} = '';
4148: $resourcedata{$symb.'delopt'} = '';
4149: $resourcedata{$symb.'options'} = "('True','False')";
4150: $resourcedata{$symb.'hiddenparts'} = '!option';
4151: $resourcedata{$symb.'questiontype'} = 'option';
4152: $resourcedata{$symb.'maxfoils'} = $numfoils;
4153: }
4154: for (my $k=0; $k<@{$$allanswers{$id}{$list}}; $k++) {
4155: my $iter = $k+1;
4156: $output .= " <foil name=\"foil".$k."\" value=\"";
4157: if (grep/^$$allanswers{$id}{$list}[$k]$/,@{$$settings{$id}{$list}{correctanswer}}) {
4158: $output .= "True\"";
4159: $resourcedata{$symb.'value'.$iter} = "True";
4160: } else {
4161: $output .= "False\"";
4162: $resourcedata{$symb.'value'.$iter} = "False";
4163: }
4164: if ($$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{texttype} eq 'text/html') {
4165: $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text} = &HTML::Entities::decode($$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text});
1.21 www 4166: $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text} = &Apache::loncleanup::htmlclean($$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text});
1.16 raeburn 4167: $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text} =~ s#(<img src=")([^>]+)>#$1../../resfiles/$2 />#gi;
4168: $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text} =~ s#</?p>##g;
4169: }
4170: $output .= "\><startouttext />".$$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text}."<br /><endouttext /></foil>\n";
4171: $resourcedata{$symb.'text'.$iter} = $$settings{$id}{$list}{$$allanswers{$id}{$list}[$k]}{text};
4172: }
4173: if ($context eq 'CSTR') {
4174: chomp($output);
4175: $output .= qq|
4176: </foilgroup>
4177: </optionresponse>
4178: |;
4179: }
4180: }
4181: }
4182: } elsif ($$settings{$id}{class} eq 'match') {
4183: my %allmatchers = ();
4184: my @allmatch = ();
4185: my %matchtext = ();
4186: my $anscount = 0;
4187: my %ansnum = ();
4188: my $maxfoils = 0;
4189: my $test_for_html = 0;
4190: foreach my $grp (@{$$allchoices{$id}}) {
4191: $maxfoils += @{$$settings{$id}{$grp}{correctanswer}};
4192: foreach my $answer_id (@{$$allanswers{$id}{$grp}}) {
4193: if ($$settings{$id}{$grp}{$answer_id}{texttype} eq '/text/html') {
4194:
4195: $$settings{$id}{$grp}{$answer_id}{text} = &HTML::Entities::decode($$settings{$id}{$grp}{$answer_id}{text});
4196: $test_for_html = &test_for_html($$settings{$id}{$grp}{$answer_id}{text});
1.21 www 4197: $$settings{$id}{$grp}{$answer_id}{text} = &Apache::loncleanup::htmlclean($$settings{$id}{$grp}{$answer_id}{text});
1.16 raeburn 4198: $$settings{$id}{$grp}{$answer_id}{text} =~ s#(<img src=")([^>]+)>#$1../../resfiles/$2 />#gi;
4199: $$settings{$id}{$grp}{$answer_id}{text} =~ s#</?p>##g;
4200: }
4201: unless (exists($allmatchers{$$settings{$id}{$grp}{$answer_id}{text}})) {
4202: $allmatchers{$$settings{$id}{$grp}{$answer_id}{text}} = $anscount;
4203: $allmatch[$anscount] = $$settings{$id}{$grp}{$answer_id}{text};
4204: $anscount ++;
4205:
4206: }
4207: if (grep/^$answer_id$/,@{$$settings{$id}{$grp}{correctanswer}}) {
4208: push(@{$ansnum{$grp}},$allmatchers{$$settings{$id}{$grp}{$answer_id}{text}});
4209: }
4210: }
4211: if ($context eq 'DOCS') {
4212: $matchtext{$ansnum{$grp}[0]} = $allmatch[$ansnum{$grp}[0]-1];
4213: }
4214: }
4215: my $allmatchlist = "('".join("','",@allmatch)."')";
4216: if ($context eq 'CSTR') {
4217: if ($test_for_html) {
4218: $output .= qq|
4219: <matchresponse max="$maxfoils" randomize="yes">
4220: <foilgroup>
4221: <itemgroup>
4222: |;
4223: } else {
4224: $output .= qq|
4225: <optionresponse max="10" randomize="yes">
1.25 raeburn 4226: <foilgroup options="$allmatchlist">
1.16 raeburn 4227: |;
4228: }
4229: } else {
4230: $resourcedata{$symb.'newopt'} = '';
4231: $resourcedata{$symb.'delopt'} = '';
4232: $resourcedata{$symb.'hiddenparts'} = '!option';
4233: $resourcedata{$symb.'questiontype'} = 'option';
4234: $resourcedata{$symb.'maxfoils'} = $maxfoils;
4235: }
4236: my $iter = 0;
4237: foreach my $match (@allmatch) {
4238: $iter ++;
4239: if ($context eq 'CSTR') {
4240: if ($test_for_html) {
4241: $output .= qq|
4242: <item name="ans_$iter">
4243: <startouttext />$match<endouttext />
4244: </item>
4245: |;
4246: }
4247: }
4248: }
4249: if ($context eq 'CSTR') {
4250: if ($test_for_html) {
4251: $output .= qq|
4252: </itemgroup>
4253: |;
4254: }
4255: }
4256: $iter = 0;
4257: for (my $k=0; $k<@{$$allchoices{$id}}; $k++) {
4258: if ($$settings{$id}{$$allchoices{$id}[$k]}{texttype} eq 'text/html') {
4259: $$settings{$id}{$$allchoices{$id}[$k]}{text} = &HTML::Entities::decode($$settings{$id}{$$allchoices{$id}[$k]}{text});
1.21 www 4260: $$settings{$id}{$$allchoices{$id}[$k]}{text} = &Apache::loncleanup::htmlclean($$settings{$id}{$$allchoices{$id}[$k]}{text});
1.16 raeburn 4261: $$settings{$id}{$$allchoices{$id}[$k]}{text} =~ s#(<img src=")([^>]+)>#$1../../resfiles/$2 />#gi;
4262: $$settings{$id}{$$allchoices{$id}[$k]}{text} =~ s#</?p>##g;
4263: }
4264: foreach my $ans (@{$ansnum{$$allchoices{$id}[$k]}}) {
4265: $iter ++;
4266: my $ans_id = $ans + 1;
4267: if ($context eq 'CSTR') {
4268: my $value;
4269: if ($test_for_html) {
4270: $value = 'ans_'.$ans_id;
4271: } else {
4272: $value = $allmatch[$ans];
4273: }
4274: $output .= qq|
4275: <foil location="random" value="$value" name="foil_$iter">
4276: <startouttext />$$settings{$id}{$$allchoices{$id}[$k]}{text}<endouttext />
4277: </foil>
4278:
4279: |;
4280: }
4281: }
4282: if ($context eq 'DOCS') {
4283: $resourcedata{$symb.'value'.$iter} = $matchtext{$ansnum{$$allchoices{$id}[$k]}[0]};
4284: $resourcedata{$symb.'text'.$iter} = $$settings{$id}{$$allchoices{$id}[0]}{text};
4285: }
4286: }
4287: if ($context eq 'CSTR') {
4288: $output .= qq|
4289: </foilgroup>
4290: |;
4291: if ($test_for_html) {
4292: $output .= qq|
4293: </matchresponse>
4294: |;
4295: } else {
4296: $output .= qq|
4297: </optionresponse>
4298: |;
4299: }
4300: } else {
4301: $resourcedata{$symb.'options'} = "('".join("','",@allmatch)."')";
4302: }
1.35 raeburn 4303: } elsif (($$settings{$id}{class} eq 'string') ||
4304: ($$settings{$id}{class} eq 'shortanswer')) {
1.16 raeburn 4305: my $labelnum = 0;
1.35 raeburn 4306: my @str_labels = ();
1.41 raeburn 4307: if ($cms eq 'webctce4') {
1.35 raeburn 4308: foreach my $str_id (@{$$settings{$id}{str}}) {
4309: foreach my $label (@{$$settings{$id}{$str_id}{labels}}) {
4310: push(@str_labels,$label);
4311: }
4312: }
4313: } elsif ($cms eq 'webctvista4') {
4314: @str_labels = @{$$settings{$id}{str}};
4315: }
4316: foreach my $label (@str_labels) {
4317: $labelnum ++;
4318: my $numerical = 1;
4319: if ($context eq 'DOCS') {
4320: $numerical = 0;
4321: } else {
4322: for (my $i=0; $i<@{$$settings{$id}{strings}{$label}}; $i++) {
4323: $$settings{$id}{strings}{$label}[$i] =~ s/^\s+//;
4324: $$settings{$id}{strings}{$label}[$i] =~ s/\s+$//;
4325: if ($$settings{$id}{strings}{$label}[$i] =~ m/([^\-\d\.]|\.\.)/) {
4326: $numerical = 0;
4327: }
4328: }
4329: }
4330: if ($numerical) {
4331: my $numans;
4332: my $tol;
4333: if (@{$$settings{$id}{strings}{$label}} == 1) {
4334: $tol = '5%';
4335: $numans = $$settings{$id}{strings}{$label}[0];
1.16 raeburn 4336: } else {
1.35 raeburn 4337: my $min = $$settings{$id}{strings}{$label}[0];
4338: my $max = $$settings{$id}{strings}{$label}[0];
4339: for (my $k=1; $k<@{$$settings{$id}{strings}{$label}}; $k++) {
4340: if ($$settings{$id}{strings}{$label}[$k] <= $min) {
4341: $min = $$settings{$id}{strings}{$label}[$k];
4342: }
4343: if ($$settings{$id}{strings}{$label}[$k] >= $max) {
4344: $max = $$settings{$id}{strings}{$label}[$k];
1.16 raeburn 4345: }
4346: }
1.35 raeburn 4347: $numans = ($max + $min)/2;
4348: if ($numans == 0) {
4349: my $dev = abs($max - $numans);
4350: if (abs($numans - $min) > $dev) {
4351: $dev = abs($numans - $min);
4352: }
4353: $tol = $dev;
1.16 raeburn 4354: } else {
1.35 raeburn 4355: $tol = 100*($max - $min)/($numans*2);
4356: $tol .= '%';
1.16 raeburn 4357: }
1.35 raeburn 4358: }
4359: if ($context eq 'CSTR') {
4360: if (@{$$settings{$id}{str}} > 1) {
4361: $output .= qq|
1.16 raeburn 4362: <startouttext />$labelnum.<endouttext />
4363: |;
1.35 raeburn 4364: }
4365: $output .= qq|
1.16 raeburn 4366: <numericalresponse answer="$numans">
4367: <responseparam type="tolerance" default="$tol" name="tol" description="Numerical Tolerance" />
4368: <responseparam name="sig" type="int_range,0-16" default="0,15" description="Significant Figures"
4369: />
4370: <textline />
4371: </numericalresponse>
4372: <startouttext /><br /><endouttext />
4373: |;
1.35 raeburn 4374: }
4375: } else {
4376: if ($context eq 'DOCS') {
4377: $resourcedata{$symb.'hiddenparts'} = '!string';
4378: $resourcedata{$symb.'questiontype'} = 'string';
4379: $resourcedata{$symb.'maxfoils'} = @{$$allanswers{$id}{strings}{$label}};
4380: $resourcedata{$symb.'hiddenparts'} = '!string';
4381: if ($$settings{$id}{$label}{case} eq "No") {
4382: $resourcedata{$symb.'stringtype'} = 'ci';
4383: } elsif ($$settings{$id}{$label}{case} eq "Yes") {
4384: $resourcedata{$symb.'stringtype'} = 'cs';
1.16 raeburn 4385: }
1.35 raeburn 4386: $resourcedata{$symb.'stringanswer'} = $$settings{$id}{strings}{$label}[0];
1.16 raeburn 4387: } else {
1.35 raeburn 4388: if (@{$$settings{$id}{str}} > 1) {
4389: $output .= qq|
4390: <startouttext />$labelnum.<endouttext />
4391: |;
4392: }
4393: if (@{$$settings{$id}{strings}{$label}} == 1) {
4394: my $casetype;
1.16 raeburn 4395: if ($$settings{$id}{$label}{case} eq "No") {
1.35 raeburn 4396: $casetype = 'ci';
1.16 raeburn 4397: } elsif ($$settings{$id}{$label}{case} eq "Yes") {
1.35 raeburn 4398: $casetype = 'cs';
1.16 raeburn 4399: }
1.35 raeburn 4400: $output .= qq|
1.16 raeburn 4401: <stringresponse answer="$$settings{$id}{strings}{$label}[0]" type="$casetype">
4402: <textline>
4403: </textline>
4404: </stringresponse>
4405: <startouttext /><br /><endouttext />
4406: |;
1.35 raeburn 4407: } else {
4408: my @answertext = ();
4409: for (my $k=0; $k<@{$$settings{$id}{strings}{$label}}; $k++) {
4410: $$settings{$id}{strings}{$label}[$k] =~ s/\|/\|/g;
4411: push @answertext, $$settings{$id}{strings}{$label}[$k];
4412: }
4413: my $regexpans = join('|',@answertext);
4414: $regexpans = '/^('.$regexpans.')\b/';
4415: $output .= qq|
1.16 raeburn 4416: <stringresponse answer="$regexpans" type="re">
4417: <textline>
4418: </textline>
4419: </stringresponse>
4420: <startouttext /><br /><endouttext />
4421: |;
4422: }
4423: }
4424: }
4425: }
4426: } elsif ($$settings{$id}{class} eq 'numerical') {
1.24 raeburn 4427: my %mathfns = (
4428: 'abs' => 'abs',
4429: 'acos' => 'acos',
4430: 'asin' => 'asin',
4431: 'atan' => 'atan',
4432: 'ceil' => 'ceil',
4433: 'cos' => 'cos',
4434: 'exp' => 'exp',
4435: 'fact' => 'factorial',
4436: 'floor' => 'floor',
4437: 'int' => 'int',
4438: 'ln' => 'log',
4439: 'log' => 'log',
4440: 'max' => 'max',
4441: 'min' => 'min',
4442: 'round' => 'roundto',
4443: 'sin' => 'sin',
4444: 'sqrt' => 'sqrt',
4445: 'tan' => 'tan',
4446: );
1.16 raeburn 4447: my $scriptblock = qq|
4448: <script type="loncapa/perl">
4449: |;
4450: foreach my $numid (@{$$settings{$id}{numids}}) {
4451: my $formula = $$settings{$id}{$numid}{formula};
1.24 raeburn 4452: my $pattern = join('|',(sort (keys (%mathfns))));
4453: $formula =~ s/($pattern)/\&$mathfns{$1}/g;
1.16 raeburn 4454: foreach my $var (keys %{$$settings{$id}{$numid}{vars}}) {
4455: my $decnum = $$settings{$id}{$numid}{vars}{$var}{dec};
4456: my $increment = '0.';
4457: if ($decnum == 0) {
4458: $increment = 1;
4459: } else {
4460: my $deccount = $decnum;
4461: while ($deccount > 1) {
4462: $increment.= '0';
4463: $deccount --;
4464: }
4465: $increment .= '1';
1.35 raeburn 4466: }
1.41 raeburn 4467: if ($cms eq 'webctce4') {
1.35 raeburn 4468: $formula =~ s/{($var)}/(\$$1)/g;
4469: } elsif ($cms eq 'webctvista4') {
4470: $formula =~ s/\[($var)\]/(\$$1)/g;
4471: }
1.16 raeburn 4472: $scriptblock .= qq|
4473: \$$var=&random($$settings{$id}{$numid}{vars}{$var}{min},$$settings{$id}{$numid}{vars}{$var}{max},$increment);
4474: |;
4475: }
4476: $scriptblock .= qq|
4477: \$answervar = $formula;
4478: </script>
4479: |;
4480: if ($context eq 'CSTR') {
1.22 raeburn 4481: $output = "<problem>\n".$scriptblock.$output;
1.16 raeburn 4482: my $ansformat = '';
4483: my $sigfig = '0,15';
4484: if ($$settings{$id}{$numid}{format} eq 'sig') {
4485: $sigfig = $$settings{$id}{$numid}{digits}.','.$$settings{$id}{$numid}{digits};
4486: } elsif ($$settings{$id}{$numid}{format} eq 'dec') {
4487: $ansformat = $$settings{$id}{$numid}{digits}.'f';
4488: }
4489: if ($ansformat) {
4490: $ansformat = 'format="'.$ansformat.'"';
4491: }
4492: my $tolerance = $$settings{$id}{$numid}{tolerance};
1.35 raeburn 4493: if (lc($$settings{$id}{$numid}{toltype}) eq 'percent') {
1.16 raeburn 4494: $tolerance .= '%';
4495: }
4496: my $unit = '';
4497: foreach my $unitid (@{$$settings{$id}{$numid}{units}}) {
4498: $unit .= $$settings{$id}{$numid}{$unitid}{text};
4499: }
4500: my $unitentry = '';
4501: if ($unit ne '') {
1.26 raeburn 4502: $unitentry = 'unit="'.$unit.'"';
1.16 raeburn 4503: }
4504: $output .= qq|
4505: <numericalresponse $unitentry $ansformat answer="\$answervar">
4506: <responseparam type="tolerance" default="$tolerance" name="tol" description="Numerical Tolerance" />
4507: <responseparam name="sig" type="int_range" default="$sigfig" description="Significant Figures"
4508: />
4509: <textline />
4510: </numericalresponse>
4511: |;
4512: }
4513: }
4514: }
4515: }
4516: if ($context eq 'CSTR') {
1.40 raeburn 4517: my $probdir;
1.16 raeburn 4518: my $catid = $$settings{$id}{category};
1.40 raeburn 4519: if ($catid) {
1.41 raeburn 4520: if ($cms eq 'webctce4') {
1.40 raeburn 4521: $probdir = $$catinfo{$catid}{title}.'_'.$catid;
4522: } else {
4523: $probdir = $$catinfo{$catid}{title};
4524: }
4525: $probdir =~ s/\s/_/g;
4526: $probdir =~ s/://g;
4527: } elsif (defined($dirtitle)) {
4528: $probdir = $dirtitle;
4529: }
1.16 raeburn 4530: if (!-e "$destdir/problems/$probdir") {
4531: mkdir("$destdir/problems/$probdir",0755);
4532: }
1.44 raeburn 4533: if ($allfeedback ne '') {
4534: $output .= qq|
4535: <postanswerdate>
4536: $allfeedback
4537: </postanswerdate>
4538: |;
4539: }
1.16 raeburn 4540: $output .= qq|</problem>
4541: |;
4542: my $title = $$settings{$id}{title};
4543: $title =~ s/\s/_/g;
1.40 raeburn 4544: $title =~ s/:/_/g;
1.44 raeburn 4545: $title =~ s/\//_/g;
1.39 raeburn 4546: open(PROB,">$destdir/problems/$probdir/$title.problem");
1.16 raeburn 4547: print PROB $output;
4548: close PROB;
4549: } else {
4550: # put %resourcedata;
4551: my $reply=&Apache::lonnet::cput
4552: ('resourcedata',\%resourcedata,$cdom,$cnum);
4553: }
4554: }
1.15 raeburn 4555: }
4556:
1.35 raeburn 4557: sub text_cleanup {
4558: my ($text) = @_;
4559: $text =~ s/(\&)(nbsp|gt|lt)(?!;)/$1$2;$3/gi;
4560: $text = &Apache::loncleanup::htmlclean($text);
4561: $text =~ s#(<img src=["']?)([^>]+?)(/?>)#$1../../resfiles/$2 />#gi;
4562: $text =~ s#<([bh])r>#<$1r />#g;
4563: $text =~ s#<p>#<br /><br />#g;
4564: $text =~ s#</p>##g;
4565: return $text;
4566: }
4567:
1.16 raeburn 4568: sub test_for_html {
4569: my ($source) = @_;
4570: my @tags = ();
4571: my $p = HTML::Parser->new
4572: (
4573: xml_mode => 1,
4574: start_h =>
4575: [sub {
4576: my ($tagname) = @_;
4577: push @tags, $tagname;
4578: }, "tagname"],
4579: );
4580: $p->parse($source);
4581: $p->eof;
4582: return length(@tags);
4583: }
4584:
1.15 raeburn 4585: sub write_bb6_questions {
1.30 raeburn 4586: my ($allids,$containerdir,$context,$settings,$dirname,$destdir,$res,$total,$newdir,$cid,$cdom,$cnum,$docroot) = @_;
1.50 raeburn 4587: my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
1.30 raeburn 4588: my $qnum = 0;
4589: foreach my $id (@{$allids}) {
4590: my $questiontext = $$settings{$id}{question}{text};
4591: my $question_texttype = $$settings{$id}{question}{texttype};
4592: &process_html(\$questiontext,'bb6',$question_texttype,$context,$res,$dirname,$cdom,$cnum,$docroot,$destdir);
4593: $qnum ++;
4594: my $output;
4595: my $permcontainer = $containerdir;
1.50 raeburn 4596: $permcontainer =~ s{\Q$londocroot/userfiles\E}{uploaded};
1.30 raeburn 4597: my $symb = $cid.'.'.$permcontainer.'___'.$qnum.'___lib/templates/simpleproblem.problem.0.';
4598: my %resourcedata = ();
4599: for (my $i=0; $i<10; $i++) {
4600: my $iter = $i+1;
4601: $resourcedata{$symb.'text'.$iter} = "";
4602: $resourcedata{$symb.'value'.$iter} = "unused";
4603: $resourcedata{$symb.'position'.$iter} = "random";
4604: }
4605: $resourcedata{$symb.'randomize'} = 'yes';
4606: $resourcedata{$symb.'maxfoils'} = 10;
4607: if ($context eq 'CSTR') {
4608: $output = qq|<problem>
4609: |;
4610: }
4611: $$total{prob} ++;
1.33 raeburn 4612: $questiontext .= &add_images_links('question',$context,$settings,$id,$dirname,$res);
1.30 raeburn 4613: if ($$settings{$id}{class} eq "Essay") {
4614: if ($context eq 'CSTR') {
4615: $output .= qq|<startouttext />$questiontext<endouttext />
4616: <essayresponse>
4617: <textfield></textfield>
4618: </essayresponse>
4619: |;
4620: } else {
4621: $resourcedata{$symb.'questiontext'} = $questiontext;
4622: $resourcedata{$symb.'hiddenparts'} = '!essay';
4623: $resourcedata{$symb.'questiontype'} = 'essay';
4624: }
4625: } else {
4626: if ($context eq 'CSTR') {
4627: $output .= qq|<startouttext />$questiontext\n<endouttext />|;
4628: } else {
4629: $resourcedata{$symb.'questiontext'} = $questiontext;
4630: }
4631: my $numfoils = @{$$settings{$id}{answers}};
4632: if (($$settings{$id}{class} eq 'Multiple Choice') ||
4633: ($$settings{$id}{class} eq 'True/False')) {
4634: if ($context eq 'CSTR') {
4635: $output .= qq|
4636: <radiobuttonresponse max="$numfoils" randomize="yes">
4637: <foilgroup>
4638: |;
4639: } else {
4640: $resourcedata{$symb.'hiddenparts'} = '!radio';
4641: $resourcedata{$symb.'questiontype'} = 'radio';
4642: $resourcedata{$symb.'maxfoils'} = $numfoils;
4643: }
4644: for (my $k=0; $k<$numfoils; $k++) {
4645: my $iter = $k+1;
4646: my $answer_id = $$settings{$id}{answers}[$k];
4647: my $answer_text = $$settings{$id}{$answer_id}{text};
4648: my $texttype = $$settings{$id}{$answer_id}{texttype};
4649: &process_html(\$answer_text,'bb6',$texttype,$context,$res,$dirname,$cdom,$cnum,$docroot,$destdir);
1.33 raeburn 4650: $answer_text .= &add_images_links('response',$context,$settings,$id,$dirname,$res);
1.30 raeburn 4651: $output .= " <foil name=\"foil".$k."\" value=\"";
4652: if (grep/^$answer_id$/,@{$$settings{$id}{correctanswer}}) {
4653: $output .= "true\" location=\"";
4654: $resourcedata{$symb.'value'.$iter} = "true";
4655: } else {
4656: $output .= "false\" location=\"";
4657: $resourcedata{$symb.'value'.$iter} = "false";
4658: }
4659: if (lc ($$settings{$id}{$answer_id}{text}) =~ m/^\s?([Aa]ll)|([Nn]one)\s(of\s)?the\sabove\.?/) {
4660: $output .= "bottom\"";
4661: $resourcedata{$symb.'position'.$iter} = "bottom";
4662: } else {
4663: $output .= "random\"";
4664: }
4665: $output .= '\><startouttext />'.$answer_text.
4666: '<endouttext /></foil>'."\n";
4667: $resourcedata{$symb.'text'.$iter} = $answer_text;
4668: }
4669: if ($context eq 'CSTR') {
4670: chomp($output);
4671: $output .= qq|
4672: </foilgroup>
4673: <hintgroup showoncorrect="no">
4674: <radiobuttonhint>
4675: </radiobuttonhint>
4676: <hintpart on="default">
4677: <startouttext/><endouttext />
4678: </hintpart>
4679: </hintgroup>
4680: </radiobuttonresponse>
4681: |;
4682: }
4683: } elsif ($$settings{$id}{class} eq 'Multiple Answer') {
4684: if ($context eq 'CSTR') {
4685: $output .= qq|
4686: <optionresponse max="$numfoils" randomize="yes">
4687: <foilgroup options="('True','False')">
4688: |;
4689: } else {
4690: $resourcedata{$symb.'newopt'} = '';
4691: $resourcedata{$symb.'delopt'} = '';
4692: $resourcedata{$symb.'options'} = "('True','False')";
4693: $resourcedata{$symb.'hiddenparts'} = '!option';
4694: $resourcedata{$symb.'questiontype'} = 'option';
4695: $resourcedata{$symb.'maxfoils'} = $numfoils;
4696: }
4697: for (my $k=0; $k<$numfoils; $k++) {
4698: my $iter = $k+1;
4699: my $answer_id = $$settings{$id}{answers}[$k];
4700: my $answer_text = $$settings{$id}{$answer_id}{text};
4701: my $texttype = $$settings{$id}{$answer_id}{texttype};
4702: &process_html(\$answer_text,'bb6',$texttype,$context,$res,$dirname,$cdom,$cnum,$docroot,$destdir);
1.33 raeburn 4703: $answer_text .= &add_images_links('response',$context,$settings,$id,$dirname,$res);
1.30 raeburn 4704:
4705: $output .= " <foil name=\"foil".$k."\" value=\"";
4706: if (grep/^$answer_id$/,@{$$settings{$id}{correctanswer}}) {
4707: $output .= "True\"";
4708: $resourcedata{$symb.'value'.$iter} = "True";
4709: } else {
4710: $output .= "False\"";
4711: $resourcedata{$symb.'value'.$iter} = "False";
4712: }
4713: $output .= "\><startouttext />".$answer_text."<endouttext /></foil>\n";
4714: $resourcedata{$symb.'text'.$iter} = $answer_text;
4715: }
4716: if ($context eq 'CSTR') {
4717: chomp($output);
4718: $output .= qq|
4719: </foilgroup>
4720: <hintgroup showoncorrect="no">
4721: <optionhint>
4722: </optionhint>
4723: <hintpart on="default">
4724: <startouttext/><endouttext />
4725: </hintpart>
4726: </hintgroup>
4727: </optionresponse>
4728: |;
4729: }
4730: } elsif ($$settings{$id}{class} eq 'Ordering') {
4731: my @allorder = ();
4732: if ($context eq 'CSTR') {
4733: $output .= qq|
4734: <rankresponse max="$numfoils" randomize="yes">
4735: <foilgroup>
4736: |;
4737: } else {
4738: $resourcedata{$symb.'newopt'} = '';
4739: $resourcedata{$symb.'delopt'} = '';
4740: $resourcedata{$symb.'hiddenparts'} = '!option';
4741: $resourcedata{$symb.'questiontype'} = 'option';
4742: $resourcedata{$symb.'maxfoils'} = $numfoils;
4743: }
4744: for (my $k=0; $k<$numfoils; $k++) {
4745: my $answer_id = $$settings{$id}{answers}[$k];
4746: my $answer_text = $$settings{$id}{$answer_id}{text};
4747: my $texttype = $$settings{$id}{$answer_id}{texttype};
4748: &process_html(\$answer_text,'bb6',$texttype,$context,$res,$dirname,$cdom,$cnum,$docroot,$destdir);
1.33 raeburn 4749: $answer_text .= &add_images_links('response',$context,$settings,$id,$dirname,$res);
1.30 raeburn 4750: my $iter = $k+1;
4751: if ($context eq 'CSTR') {
4752: $output .= " <foil location=\"random\" name=\"foil".$k."\" value=\"".$$settings{$id}{$answer_id}{order}."\"><startouttext />".$answer_text."<endouttext /></foil>\n";
4753: } else {
4754: $resourcedata{$symb.'text'.$iter} = $answer_text;
4755: $resourcedata{$symb.'value'.$iter} = $$settings{$id}{$answer_id}{order};
4756: if (!grep/^$$settings{$id}{$answer_id}{order}$/,@allorder) {
4757: push(@allorder,$$settings{$id}{$answer_id}{order});
4758: }
4759: }
4760: }
4761: if ($context eq 'CSTR') {
4762: chomp($output);
4763: $output .= qq|
4764: </foilgroup>
4765: </rankresponse>
4766: |;
4767: } else {
4768: @allorder = sort {$a <=> $b} @allorder;
4769: $resourcedata{$symb.'options'} = "('".join("','",@allorder)."')";
4770: }
4771: } elsif ($$settings{$id}{class} eq 'Fill in the Blank') {
4772: my $numerical = 1;
4773: if ($context eq 'DOCS') {
4774: $numerical = 0;
4775: } else {
4776: for (my $k=0; $k<@{$$settings{$id}{correctanswer}}; $k++) {
4777: if ($$settings{$id}{correctanswer}[$k] =~ m/([^\d\.]|\.\.)/) {
4778: $numerical = 0;
4779: }
4780: }
4781: }
4782: if ($numerical) {
4783: my $numans;
4784: my $tol;
4785: if (@{$$settings{$id}{correctanswer}} == 1) {
4786: $tol = 5;
4787: $numans = $$settings{$id}{correctanswer}[0];
4788: } else {
4789: my $min = $$settings{$id}{correctanswer}[0];;
4790: my $max = $min;
4791: for (my $k=1; $k<@{$$settings{$id}{correctanswer}}; $k++) {
4792: if ($$settings{$id}{correctanswer}[$k] <= $min) {
4793: $min = $$settings{$id}{correctanswer}[$k];
4794: }
4795: if ($$settings{$id}{correctanswer}[$k] >= $max) {
4796: $max = $$settings{$id}{correctanswer}[$k];
4797: }
4798: }
4799: $numans = ($max + $min)/2;
4800: $tol = 100*($max - $min)/($numans*2);
4801: $tol = 5;
4802: }
4803: if ($context eq 'CSTR') {
4804: $output .= qq|
4805: <numericalresponse answer="$numans">
4806: <responseparam type="tolerance" default="$tol%" name="tol" description="Numerical Tolerance" />
4807: <responseparam name="sig" type="int_range,0-16" default="0,15" description="Significant Figures"
4808: />
4809: <textline />
4810: </numericalresponse>
4811: <hintgroup showoncorrect="no">
4812: <numericalhint>
4813: </numericalhint>
4814: <hintpart on="default">
4815: <startouttext/><endouttext />
4816: </hintpart>
4817: </hintgroup>
4818: |;
4819: }
4820: } else {
4821: if ($context eq 'DOCS') {
4822: $resourcedata{$symb.'hiddenparts'} = '!string';
4823: $resourcedata{$symb.'questiontype'} = 'string';
4824: $resourcedata{$symb.'maxfoils'} = 1;
4825: $resourcedata{$symb.'hiddenparts'} = '!string';
4826: $resourcedata{$symb.'stringtype'} = 'ci';
4827: $resourcedata{$symb.'stringanswer'} = $$settings{$id}{correctanswer}[0];
4828: } else {
4829: if (@{$$settings{$id}{correctanswer}} == 1) {
4830: $output .= qq|
4831: <stringresponse answer="$$settings{$id}{correctanswer}[0];" type="ci">
4832: <textline>
4833: </textline>
4834: </stringresponse>
4835: <hintgroup showoncorrect="no">
4836: <stringhint type="cs">
4837: </stringhint>
4838: <hintpart on="default">
4839: <startouttext/><endouttext />
4840: </hintpart>
4841: </hintgroup>
4842: |;
4843: } else {
4844: my @answertext = ();
4845: for (my $k=0; $k<@{$$settings{$id}{correctanswer}}; $k++) {
4846: my $answer_text = $$settings{$id}{correctanswer}[$k];
4847: $answer_text =~ s/\|/\|/g;
4848: push @answertext, $answer_text;
4849: }
4850: my $regexpans = join('|',@answertext);
4851: $regexpans = '/^('.$regexpans.')\b/';
4852: $output .= qq|
4853: <stringresponse answer="$regexpans" type="re">
4854: <textline>
4855: </textline>
4856: </stringresponse>
4857: <hintgroup showoncorrect="no">
4858: <stringhint type="cs">
4859: </stringhint>
4860: <hintpart on="default">
4861: <startouttext/><endouttext />
4862: </hintpart>
4863: </hintgroup>
4864: |;
4865: }
4866: }
4867: }
4868: } elsif ($$settings{$id}{class} eq "Matching") {
4869: my @allmatchers = ();
4870: my %matchtext = ();
4871: if ($context eq 'CSTR') {
4872: $output .= qq|
4873: <matchresponse max="10" randomize="yes">
4874: <foilgroup>
4875: <itemgroup>
4876: |;
4877: } else {
4878: $resourcedata{$symb.'newopt'} = '';
4879: $resourcedata{$symb.'delopt'} = '';
4880: $resourcedata{$symb.'hiddenparts'} = '!option';
4881: $resourcedata{$symb.'questiontype'} = 'option';
4882: $resourcedata{$symb.'maxfoils'} = $numfoils;
4883: }
4884: for (my $k=0; $k<$$settings{$id}{allchoices}; $k++) {
4885: my $choice_id = 'rightmatch'.$k;
4886: my $choice_text = $$settings{$id}{$choice_id}{text};
4887: my $texttype = $$settings{$id}{$choice_id}{texttype};
4888: my $choice_plaintext = &remove_html($choice_text);
4889: &process_html(\$choice_text,'bb6',$texttype,$context,$res,$dirname,$cdom,$cnum,$docroot,$destdir);
1.33 raeburn 4890: $choice_text .= &add_images_links($choice_id,$context,$settings,$id,$dirname,$res);
1.30 raeburn 4891: push(@allmatchers,$choice_plaintext);
4892: if ($context eq 'CSTR') {
4893: $output .= qq|
4894: <item name="$choice_id">
4895: <startouttext />$choice_text<endouttext />
4896: </item>
4897: |;
4898: }
4899: }
4900: if ($context eq 'CSTR') {
4901: $output .= qq|
4902: </itemgroup>
4903: |;
4904: }
4905: for (my $k=0; $k<$numfoils; $k++) {
4906: my $answer_id = $$settings{$id}{answers}[$k];
4907: my $answer_text = $$settings{$id}{$answer_id}{text};
4908: my $texttype = $$settings{$id}{$answer_id}{texttype};
4909: &process_html(\$answer_text,'bb6',$texttype,$context,$res,$dirname,$cdom,$cnum,$docroot,$destdir);
1.33 raeburn 4910: $answer_text .= &add_images_links($answer_id,$context,$settings,$id,$dirname,$res);
1.30 raeburn 4911: if ($context eq 'CSTR') {
4912: $output .= '
4913: <foil location="random" value="rightmatch'.$$settings{$id}{$$settings{$id}{$answer_id}{correctanswer}}{order}.'" name="'.$answer_id.'">
4914: <startouttext />'.$answer_text.'<endouttext />
4915: </foil>
4916: ';
4917: } else {
4918: my $iter = $k+1;
4919: $resourcedata{$symb.'value'.$iter} = "$allmatchers[$$settings{$id}{$$settings{$id}{$answer_id}{correctanswer}}{order}]";
4920: $resourcedata{$symb.'text'.$iter} = $answer_text;
4921: }
4922: }
4923: if ($context eq 'CSTR') {
4924: $output .= qq|
4925: </foilgroup>
4926: </matchresponse>
4927: |;
4928: } else {
4929: $resourcedata{$symb.'options'} = "('".join("','",@allmatchers)."')";
4930: }
4931: }
4932: }
4933: if ($context eq 'CSTR') {
4934:
4935: $output .= qq|
4936: <postanswerdate>
4937: $$settings{$id}{solutionfeedback}{text}
4938: </postanswerdate>
4939: </problem>
4940: |;
4941: my $title = $$settings{title};
4942: $title =~ s/\s/_/g;
4943: $title =~ s/\W//g;
4944: $title .= '_'.$id;
1.39 raeburn 4945: open(PROB,">$newdir/$title.problem");
1.30 raeburn 4946: print PROB $output;
4947: close PROB;
4948: } else {
4949: # put %resourcedata;
4950: my $reply=&Apache::lonnet::cput
4951: ('resourcedata',\%resourcedata,$cdom,$cnum);
4952: }
4953: }
1.20 raeburn 4954: }
4955:
4956: sub retrieve_image {
4957: my ($context,$res,$dirname,$cdom,$cname,$docroot,$destdir,$urlpath,$filename) = @_;
4958: my $contents;
4959: my $url = $urlpath.$filename;
4960: my $ua=new LWP::UserAgent;
4961: my $request=new HTTP::Request('GET',$url);
4962: my $response=$ua->request($request);
4963: if ($response->is_success) {
4964: $contents = $response->content;
4965: if (!-e "$docroot/$res") {
4966: mkdir("$docroot/$res",0755);
4967: }
4968: if (!-e "$docroot/$res/webimages") {
4969: mkdir("$docroot/$res/webimages",0755);
4970: }
4971: open(my $fh,">$docroot/$res/webimages/$filename");
4972: print $fh $contents;
4973: close($fh);
4974: if ($context eq 'DOCS') {
4975: my $copyfile = $dirname.'/'.$filename;
4976: my $source = "$docroot/$res/webimages/$filename";
4977: my $fileresult;
4978: if (-e $source) {
1.31 raeburn 4979: $fileresult = &Apache::lonnet::process_coursefile('copy',$cname,$cdom,$copyfile,$source);
1.20 raeburn 4980: }
4981: return $fileresult;
4982: } elsif ($context eq 'CSTR') {
4983: if (!-e "$destdir/resfiles/$res") {
4984: mkdir("$destdir/resfiles/$res",0755);
4985: }
4986: if (!-e "$destdir/resfiles/$res/webimages") {
4987: mkdir("$destdir/resfiles/$res/webimages",0755);
4988: }
4989: rename("$docroot/$res/webimages/$filename","$destdir/resfiles/$res/webimages/$filename");
4990: return 'ok';
4991: }
4992: } else {
4993: return -1;
4994: }
1.15 raeburn 4995: }
4996:
1.2 raeburn 4997: # ---------------------------------------------------------------- Process Blackboard Announcements
4998: sub process_announce {
1.3 raeburn 4999: my ($res,$docroot,$destdir,$settings,$globalresref,$seqstem,$resrcfiles) = @_;
1.2 raeburn 5000: my $xmlfile = $docroot.'/'.$res.".dat";
5001: my @state = ();
5002: my @assess = ();
5003: my $id;
5004: my $p = HTML::Parser->new
5005: (
5006: xml_mode => 1,
5007: start_h =>
5008: [sub {
5009: my ($tagname, $attr) = @_;
5010: push @state, $tagname;
5011: if ("@state" eq "ANNOUNCEMENT TITLE") {
5012: $$settings{title} = $attr->{value};
5013: $$settings{startassessment} = ();
1.7 raeburn 5014: } elsif ("@state" eq "ANNOUNCEMENT DESCRIPTION FLAGS ISHTML") {
1.2 raeburn 5015: $$settings{ishtml} = $attr->{value};
5016: } elsif ("@state" eq "ANNOUNCEMENT DESCRIPTION FLAGS ISNEWLINELITERAL" ) {
5017: $$settings{isnewline} = $attr->{value};
5018: } elsif ("@state" eq "ANNOUNCEMENT ISPERMANENT" ) {
5019: $$settings{ispermanent} = $attr->{value};
5020: } elsif ("@state" eq "ANNOUNCEMENT DATES UPDATED") {
5021: $$settings{dates} = $attr->{value};
5022: } elsif ("@state" eq "ANNOUNCEMENT FILES STARTASSESSMENT" ) {
5023: $id = $attr->{id};
5024: %{$$settings{startassessment}{$id}} = ();
5025: push @assess,$id;
5026: } elsif ("@state" eq "ANNOUNCEMENT FILES STARTASSESSMENT ATTRIB" ) {
5027: my $key = $attr->{key};
5028: $$settings{startassessment}{$id}{$key} = $attr->{value};
5029: }
5030: }, "tagname, attr"],
5031: text_h =>
5032: [sub {
5033: my ($text) = @_;
5034: if ("@state" eq "ANNOUNCEMENT DESCRIPTION TEXT") {
5035: $$settings{text} = $text;
5036: }
5037: }, "dtext"],
5038: end_h =>
5039: [sub {
5040: my ($tagname) = @_;
5041: pop @state;
5042: }, "tagname"],
5043: );
5044: $p->unbroken_text(1);
5045: $p->parse_file($xmlfile);
5046: $p->eof;
5047:
5048: if (defined($$settings{text})) {
5049: if ($$settings{ishtml} eq "false") {
5050: if ($$settings{isnewline} eq "true") {
5051: $$settings{text} =~ s#\n#<br/>#g;
5052: }
5053: } else {
5054: $$settings{text} = &HTML::Entities::decode($$settings{text});
5055: }
5056: }
5057:
5058: if (@assess > 0) {
5059: foreach my $id (@assess) {
1.3 raeburn 5060: $$settings{text} = "A $$settings{startassessment}{$id}{assessment_type}, entitled $$globalresref{$$settings{startassessment}{$id}{assessment_id}}{title} is available. Click <a href='$seqstem/pages/$$settings{startassessment}{$id}{assessment_id}.page' target='quizpage'>here</a> to enter the page that contains the problems in this assessment.";
1.2 raeburn 5061: }
5062: }
5063:
5064: open(FILE,">$destdir/resfiles/$res.html");
5065: push @{$resrcfiles}, "$res.html";
5066: print FILE qq|<html>
5067: <head>
5068: <title>$$settings{title}</title>
5069: </head>
5070: <body bgcolor='#ffffff'>
5071: <table>
5072: <tr>
1.3 raeburn 5073: <td bgcolor='#CCCCFF'>$$settings{title} - announcement date: $$settings{dates}</td>
1.2 raeburn 5074: </tr>
5075: </table>
5076: <br/>
5077: $$settings{text}
5078: |;
5079: print FILE qq|
5080: </body>
5081: </html>|;
5082: close(FILE);
5083: }
5084:
5085: # ---------------------------------------------------------------- Process Blackboard Content
5086: sub process_content {
1.10 raeburn 5087: my ($cms,$res,$context,$docroot,$destdir,$settings,$dom,$user,$resrcfiles,$packages,$hrefs) = @_;
1.2 raeburn 5088: my $xmlfile = $docroot.'/'.$res.".dat";
5089: my $destresdir = $destdir;
1.50 raeburn 5090: my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'};
1.7 raeburn 5091: if ($context eq 'CSTR') {
1.50 raeburn 5092: $destresdir =~ s{^\Q$londocroot/priv/\E}{/res/};
1.7 raeburn 5093: } elsif ($context eq 'DOCS') {
1.50 raeburn 5094: $destresdir =~ s{^\Q$londocroot/userfiles\E}{/uploaded};
1.7 raeburn 5095: }
1.10 raeburn 5096: my $filetag = '';
5097: if ($cms eq 'bb5') {
5098: $filetag = 'FILEREF';
5099: } elsif ($cms eq 'bb6') {
5100: $filetag = 'FILE';
5101: }
1.2 raeburn 5102: my $filecount = 0;
5103: my @allrelfiles = ();
5104: my @state;
5105: @{$$settings{files}} = ();
5106: my $p = HTML::Parser->new
5107: (
5108: xml_mode => 1,
5109: start_h =>
5110: [sub {
5111: my ($tagname, $attr) = @_;
5112: push @state, $tagname;
1.10 raeburn 5113: if ("@state" eq "CONTENT ") {
1.2 raeburn 5114: %{$$settings{maindata}} = ();
1.10 raeburn 5115: } elsif ("@state" eq "CONTENT TITLECOLOR") {
5116: $$settings{titlecolor} = $attr->{value};
1.7 raeburn 5117: } elsif ("@state" eq "CONTENT MAINDATA TEXTCOLOR") {
1.2 raeburn 5118: $$settings{maindata}{color} = $attr->{value};
1.7 raeburn 5119: } elsif ("@state" eq "CONTENT MAINDATA FLAGS ISHTML") {
1.2 raeburn 5120: $$settings{maindata}{ishtml} = $attr->{value};
1.7 raeburn 5121: } elsif ("@state" eq "CONTENT MAINDATA FLAGS ISNEWLINELITERAL") {
1.2 raeburn 5122: $$settings{maindata}{isnewline} = $attr->{value};
1.10 raeburn 5123: } elsif ("@state" eq "CONTENT BODY TYPE") {
5124: $$settings{maindata}{bodytype} = $attr->{value};
1.2 raeburn 5125: } elsif ("@state" eq "CONTENT FLAGS ISAVAILABLE" ) {
5126: $$settings{isavailable} = $attr->{value};
5127: } elsif ("@state" eq "CONTENT FLAGS ISFOLDER" ) {
5128: $$settings{isfolder} = $attr->{value};
5129: } elsif ("@state" eq "CONTENT FLAGS LAUNCHINNEWWINDOW" ) {
5130: $$settings{newwindow} = $attr->{value};
1.10 raeburn 5131: } elsif ("@state" eq "CONTENT FILES $filetag") {
1.2 raeburn 5132: %{$$settings{files}[$filecount]} = ();
5133: %{$$settings{files}[$filecount]{registry}} = ();
5134: } elsif ("@state" eq "CONTENT FILES FILEREF RELFILE" ) {
5135: $$settings{files}[$filecount]{'relfile'} = $attr->{value};
5136: push @allrelfiles, $attr->{value};
1.10 raeburn 5137: } elsif ("@state" eq "CONTENT FILES $filetag MIMETYPE") {
1.2 raeburn 5138: $$settings{files}[$filecount]{mimetype} = $attr->{value};
1.10 raeburn 5139: } elsif ("@state" eq "CONTENT FILES $filetag CONTENTTYPE") {
1.2 raeburn 5140: $$settings{files}[$filecount]{contenttype} = $attr->{value};
1.10 raeburn 5141: } elsif ("@state" eq "CONTENT FILES $filetag FILEACTION") {
1.2 raeburn 5142: $$settings{files}[$filecount]{fileaction} = $attr->{value};
1.10 raeburn 5143: } elsif ("@state" eq "CONTENT FILES $filetag PACKAGEPARENT") {
1.2 raeburn 5144: $$settings{files}[$filecount]{packageparent} = $attr->{value};
1.10 raeburn 5145: } elsif ("@state" eq "CONTENT FILES $filetag LINKNAME") {
1.2 raeburn 5146: $$settings{files}[$filecount]{linkname} = $attr->{value};
1.10 raeburn 5147: } elsif ("@state" eq "CONTENT FILES $filetag REGISTRY REGISTRYENTRY") {
1.2 raeburn 5148: my $key = $attr->{key};
5149: $$settings{files}[$filecount]{registry}{$key} = $attr->{value};
5150: }
5151: }, "tagname, attr"],
5152: text_h =>
5153: [sub {
5154: my ($text) = @_;
5155: if ("@state" eq "CONTENT TITLE") {
5156: $$settings{title} = $text;
1.10 raeburn 5157: } elsif ( ("@state" eq "CONTENT MAINDATA TEXT") || ("@state" eq "CONTENT BODY TEXT") ) {
1.2 raeburn 5158: $$settings{maindata}{text} = $text;
1.10 raeburn 5159: } elsif ("@state" eq "CONTENT FILES $filetag REFTEXT") {
1.2 raeburn 5160: $$settings{files}[$filecount]{reftext} = $text;
1.10 raeburn 5161: } elsif ("@state" eq "CONTENT FILES FILE NAME" ) {
5162: $$settings{files}[$filecount]{'relfile'} = $text;
5163: push @allrelfiles, $text;
1.2 raeburn 5164: }
5165: }, "dtext"],
5166: end_h =>
5167: [sub {
5168: my ($tagname) = @_;
1.10 raeburn 5169: if ("@state" eq "CONTENT FILES $filetag") {
1.2 raeburn 5170: $filecount ++;
5171: }
5172: pop @state;
5173: }, "tagname"],
5174: );
5175: $p->unbroken_text(1);
5176: $p->parse_file($xmlfile);
5177: $p->eof;
5178: my $linktag = '';
5179: my $fontcol = '';
5180: if (@{$$settings{files}} > 0) {
5181: for (my $filecount=0; $filecount<@{$$settings{files}}; $filecount++) {
5182: if ($$settings{files}[$filecount]{'fileaction'} eq 'embed') {
5183: if ( $$settings{files}[$filecount]{reftext} =~ m#<\!\-\-\s_(\d+)\\_\s\-\-\>#) {
5184: my $newtag = qq|<img src="$destresdir/resfiles/$res/$$settings{files}[$filecount]{relfile}"/>|;
5185: $$settings{maindata}{text} =~ s#<\!\-\-\s_/($1)\\_\s\-\-\>#$newtag#;
5186: } elsif ( $$settings{files}[$filecount]{reftext} =~m#^_/(\d+)\\_$# ) {
5187: my $reftag = $1;
5188: my $newtag;
5189: if ($$settings{files}[$filecount]{mimetype} =~ m/^image/) {
5190: $newtag = qq|<img src="$destresdir/resfiles/$res/$$settings{files}[$filecount]{relfile}"|;
5191: if ( defined($$settings{files}[$filecount]{registry}{alttext}) ) {
5192: $newtag .= qq| alt="$$settings{files}[$filecount]{registry}{alttext}"|;
5193: }
5194: if ( defined($$settings{files}[$filecount]{registry}{alignment}) )
5195: {
5196: $newtag .= qq| align="$$settings{files}[$filecount]{registry}{alignment}"|;
1.1 raeburn 5197: }
1.2 raeburn 5198: if ( defined($$settings{files}[$filecount]{registry}{border}) ) {
5199: $newtag .= qq| border="$$settings{files}[$filecount]{registry}{border}"|;
5200: }
5201: $newtag .= " />";
5202: my $reftext = $$settings{files}[$filecount]{reftext};
5203: my $fname = $$settings{files}[$filecount]{'relfile'};
5204: $$settings{maindata}{text} =~ s/<!\-\-\sCOMMENT\sBLOCK\sFOR\sEMBEDDED\sFILE:\s$fname[\s\n]+DO\sNOT\sEDIT\sTHIS\sCOMMENT\sBLOCK[\s\n]+//;
5205: # $$settings{maindata}{text} =~ s/DO\sNOT\sEDIT\sTHIS\sCOMMENT\sBLOCK[\s\n]+//;
5206: $$settings{maindata}{text} =~ s/Move\swhole\scomment\sto\schange\sfile\splacement\swithin\spage\.[\s\n]+//;
5207: $$settings{maindata}{text} =~ s/_\/$reftag\\_/$newtag/;
5208: $$settings{maindata}{text} =~ s/END\sOF\sBLOCK\sON\sNEXT\sLINE[\s\n]+//;
5209: $$settings{maindata}{text} =~ s/\-\->//;
5210: # $$settings{maindata}{text} =~ s/<!\-\-\sCOMMENT\sBLOCK\sFOR\sEMBEDDED\sFILE:\s$fname[\s\n]+DO\sNOT\sEDIT\sTHIS\sCOMMENT\sBLOCK[\s\n\]+_\/$reftag\\_[\s\n]+END\sOF\sBLOCK\sON\sNEXT\sLINE[\s\n\]+\-\->/$newtag/;
5211: # print STDERR $$settings{maindata}{text};
5212: }
5213: } else {
5214: my $filename=$$settings{files}[$filecount]{'relfile'};
5215: my $newfilename="$destresdir/resfiles/$res/$$settings{files}[$filecount]{relfile}";
1.10 raeburn 5216: $$settings{maindata}{text} =~ s#(src|SRC|value)=("|")$filename("|")#$1="$newfilename"#g;
1.2 raeburn 5217: }
5218: } elsif ($$settings{files}[$filecount]{fileaction} eq 'link') {
5219: unless (($$settings{files}[$filecount]{packageparent} ne '') && (grep/^$$settings{files}[$filecount]{packageparent}$/,@{$$settings{files}}) ) {
5220: $linktag .= qq|<a href="$destresdir/resfiles/$res/$$settings{files}[$filecount]{relfile}"|;
5221: if ($$settings{newwindow} eq "true") {
5222: $linktag .= qq| target="$res$filecount"|;
1.1 raeburn 5223: }
1.2 raeburn 5224: foreach my $entry (keys %{$$settings{files}[$filecount]{registry}}) {
5225: $linktag .= qq| $entry="$$settings{files}[$filecount]{registry}{$entry}"|;
1.1 raeburn 5226: }
1.2 raeburn 5227: $linktag .= qq|>$$settings{files}[$filecount]{linkname}</a><br/>\n|;
1.1 raeburn 5228: }
1.10 raeburn 5229: } elsif ( ($$settings{files}[$filecount]{fileaction} eq 'PACKAGE') || ($$settings{files}[$filecount]{fileaction} eq 'package') ) {
5230: my $open_package = '';
5231: if ($$settings{files}[$filecount]{'relfile'} =~ m|\.zip$|i) {
5232: $open_package = &expand_zip("$docroot/$res",$$settings{files}[$filecount]{'relfile'});
5233: }
5234: if ($open_package eq 'ok') {
5235: opendir(DIR,"$docroot/$res");
5236: my @dircontents = grep(!/^\./,readdir(DIR));
5237: closedir(DIR);
5238: push @{$resrcfiles}, @dircontents;
5239: @{$$hrefs{$res}} = @dircontents;
5240: push @{$packages}, $res;
5241: }
5242: } elsif ( ($$settings{files}[$filecount]{fileaction} eq 'BROKEN_IMAGE') && ($cms eq 'bb6') ) {
5243: my $filename=$$settings{files}[$filecount]{'relfile'};
5244: my $newfilename="$destresdir/resfiles/$res/$$settings{files}[$filecount]{relfile}";
5245: $$settings{maindata}{text} =~ s#(src|SRC|value)=("|")$filename("|")#$1="$newfilename"#g;
5246: } elsif ( ($$settings{files}[$filecount]{fileaction} eq 'LINK') && ($cms eq 'bb6') ) {
5247: my $filename=$$settings{files}[$filecount]{'relfile'};
5248: my $newfilename="$destresdir/resfiles/$res/$$settings{files}[$filecount]{relfile}";
5249: my $filetitle = $$settings{files}[$filecount]{'linkname'};
5250: $$settings{maindata}{text} = '<a href="'.$newfilename.'">'.$filetitle.'</a><br /><br />'. $$settings{maindata}{text};
1.1 raeburn 5251: }
1.2 raeburn 5252: }
5253: }
5254: if (defined($$settings{maindata}{textcolor})) {
5255: $fontcol = qq|<font color="$$settings{maindata}{textcolor}">|;
5256: }
5257: if (defined($$settings{maindata}{text})) {
1.10 raeburn 5258: if ($$settings{maindata}{bodytype} eq "S") {
5259: $$settings{maindata}{text} =~ s#\n#<br/>#g;
5260: }
1.2 raeburn 5261: if ($$settings{maindata}{ishtml} eq "false") {
5262: if ($$settings{maindata}{isnewline} eq "true") {
5263: $$settings{maindata}{text} =~ s#\n#<br/>#g;
5264: }
5265: } else {
1.10 raeburn 5266: # $$settings{maindata}{text} = &HTML::Entities::decode($$settings{maindata}{text});
1.2 raeburn 5267: }
5268: }
5269:
1.14 raeburn 5270: if (!open(FILE,">$destdir/resfiles/$res.html")) {
5271: &Apache::lonnet::logthis("IMS import error: Cannot open file - $destdir/resfiles/$res.html - $!");
5272: } else {
5273: push @{$resrcfiles}, "$res.html";
5274: my $htmldoc = 0;
5275: # if ($$settings{maindata}{text} =~ m-<(html|HTML)>.+<\\(html|HTML)-) {
5276: if ($$settings{maindata}{text} =~ m-<(html|HTML)>-) {
5277: $htmldoc = 1;
5278: }
5279: unless ($htmldoc) {
5280: print FILE qq|<html>
1.2 raeburn 5281: <head>
5282: <title>$$settings{title}</title>
5283: </head>
5284: <body bgcolor='#ffffff'>
5285: $fontcol
5286: |;
1.14 raeburn 5287: }
5288: unless ($$settings{title} eq '') {
5289: print FILE qq|$$settings{title}<br/><br/>\n|;
5290: }
5291: print FILE qq|
1.2 raeburn 5292: $$settings{maindata}{text}
5293: $linktag|;
1.14 raeburn 5294: unless ($htmldoc) {
5295: if (defined($$settings{maindata}{textcolor})) {
5296: print FILE qq|</font>|;
5297: }
5298: print FILE qq|
1.2 raeburn 5299: </body>
5300: </html>|;
1.14 raeburn 5301: }
5302: close(FILE);
1.10 raeburn 5303: }
1.2 raeburn 5304: }
5305:
5306:
5307: sub process_angelboards {
5308: my ($context,$destdir,$boards,$timestamp,$crs,$cdom,$uname,$db_handling,$messages,$items,$resources,$hrefs,$tempdir,$longcrs) = @_;
5309: for (my $i=0; $i<@{$boards}; $i++) {
5310: my %msgidx = ();
5311: my $forumtext = '';
5312: my $boardname = 'bulletinpage_'.$$timestamp[$i];
5313: my $forumfile = $tempdir.'/_assoc/'.$$boards[$i].'/pg'.$$boards[$i].'.htm';
5314: my @state = ();
5315: my $p = HTML::Parser->new
5316: (
5317: xml_mode => 1,
5318: start_h =>
5319: [sub {
5320: my ($tagname, $attr) = @_;
5321: push @state, $tagname;
5322: }, "tagname, attr"],
5323: text_h =>
5324: [sub {
5325: my ($text) = @_;
5326: if ("@state" eq "html body div div") {
5327: $forumtext = $text;
5328: }
5329: }, "dtext"],
5330: end_h =>
5331: [sub {
5332: my ($tagname) = @_;
5333: pop @state;
5334: }, "tagname"],
5335: );
5336: $p->parse_file($forumfile);
5337: $p->eof;
5338:
5339: my %boardinfo = (
5340: 'aaa_title' => $$items{$$resources{$$boards[$i]}{revitm}}{title},
5341: 'bbb_content' => $forumtext,
5342: 'ccc_webreferences' => '',
5343: 'uploaded.lastmodified' => time,
5344: );
5345: my $msgcount = 0;
5346:
5347: my $putresult = &Apache::lonnet::put($boardname,\%boardinfo,$cdom,$crs);
5348: if ($db_handling eq 'importall') {
5349: foreach my $msg_id (@{$$messages{$$boards[$i]}}) {
5350: $msgcount ++;
5351: $msgidx{$msg_id} = $msgcount;
5352: my %contrib = (
5353: 'sendername' => 'NoName',
5354: 'senderdomain' => $cdom,
5355: 'screenname' => '',
5356: 'message' => $$items{$$resources{$msg_id}{revitm}}{title}
5357: );
5358: unless ( $$items{$$resources{$msg_id}{revitm}}{parentseq} eq $$resources{$$boards[$i]}{revitm} ) {
5359: unless ( $msgidx{$$items{$$items{$$resources{$msg_id}{revitm}}{parentseq}}{resnum}} eq ''){
5360: $contrib{replyto} = $msgidx{$$items{$$items{$$resources{$msg_id}{revitm}}{parentseq}}{resnum}};
1.1 raeburn 5361: }
1.2 raeburn 5362: }
5363: if ( @{$$hrefs{$msg_id}} > 1 ) {
5364: my $newurl = '';
5365: foreach my $file (@{$$hrefs{$msg_id}}) {
5366: unless ($file eq 'pg'.$msg_id.'.htm') {
5367: $newurl = $msg_id.$file;
5368: unless ($longcrs eq '') {
5369: if ($context eq 'CSTR') {
5370: if (!-e "/home/httpd/lonUsers/$cdom/$longcrs/userfiles") {
5371: mkdir("/home/httpd/lonUsers/$cdom/$longcrs/userfiles",0755);
5372: }
5373: if (!-e "/home/httpd/lonUsers/$cdom/$longcrs/userfiles/$newurl") {
5374: rename("$destdir/resfiles/$msg_id/$file","/home/httpd/lonUsers/$cdom/$longcrs/userfiles/$newurl");
5375: }
5376: }
5377: $contrib{attachmenturl} = '/uploaded/'.$cdom.'/'.$crs.'/'.$file;
5378: }
1.1 raeburn 5379: }
5380: }
5381: }
1.2 raeburn 5382: my $xmlfile = $tempdir.'/_assoc/'.$msg_id.'/'.$$resources{$msg_id}{file};
5383: &angel_message($msg_id,\%contrib,$xmlfile);
5384: unless ($$resources{$msg_id}{file} eq '') {
5385: unlink($xmlfile);
5386: }
5387: my $symb = 'bulletin___'.$$timestamp[$i].'___adm/wrapper/adm/'.$cdom.'/'.$uname.'/'.$$timestamp[$i].'/bulletinboard';
5388: my $postresult = &addposting($symb,\%contrib,$cdom,$crs);
5389: }
5390: }
5391: }
5392: }
5393:
5394: # ---------------------------------------------------------------- Process ANGEL message board messages
5395: sub angel_message {
5396: my ($msg_id,$contrib,$xmlfile) = @_;
5397: my @state = ();
5398: my $p = HTML::Parser->new
5399: (
5400: xml_mode => 1,
5401: start_h =>
5402: [sub {
5403: my ($tagname, $attr) = @_;
5404: push @state, $tagname;
5405: }, "tagname, attr"],
5406: text_h =>
5407: [sub {
5408: my ($text) = @_;
5409: if ("@state" eq "html body table tr td div small span") {
5410: $$contrib{'plainname'} = $text;
5411: } elsif ("@state" eq "html body div div") {
5412: $$contrib{'message'} .= '<br /><br />'.$text;
5413: }
5414: }, "dtext"],
5415: end_h =>
5416: [sub {
5417: my ($tagname) = @_;
5418: pop @state;
5419: }, "tagname"],
5420: );
5421: $p->parse_file($xmlfile);
5422: $p->eof;
5423: }
5424:
5425: # ---------------------------------------------------------------- ANGEL content
5426: sub angel_content {
5427: my ($res,$docroot,$destdir,$settings,$dom,$user,$type,$title,$resrcfiles) = @_;
5428: my $xmlfile = $docroot.'/_assoc/'.$res.'/pg'.$res.'.htm';
5429: my $filecount = 0;
5430: my $firstline;
5431: my $lastline;
5432: my @buffer = ();
5433: my @state;
5434: @{$$settings{links}} = ();
5435: my $p = HTML::Parser->new
5436: (
5437: xml_mode => 1,
5438: start_h =>
5439: [sub {
5440: my ($tagname, $attr) = @_;
5441: push @state, $tagname;
5442: }, "tagname, attr"],
5443: text_h =>
5444: [sub {
5445: my ($text) = @_;
5446: if ("@state" eq "html body table tr td div small span") {
5447: $$settings{'subtitle'} = $text;
5448: } elsif ("@state" eq "html body div div") {
5449: $$settings{'text'} = $text;
5450: } elsif ("@state" eq "html body div div a") {
5451: push @{$$settings{'links'}}, $text;
5452: }
5453: }, "dtext"],
5454: end_h =>
5455: [sub {
5456: my ($tagname) = @_;
5457: pop @state;
5458: }, "tagname"],
5459: );
5460: $p->parse_file($xmlfile);
5461: $p->eof;
5462: if ($type eq "PAGE") {
5463: open(FILE,"<$xmlfile");
5464: @buffer = <FILE>;
5465: close(FILE);
5466: chomp(@buffer);
5467: $firstline = -1;
5468: $lastline = 0;
5469: for (my $i=0; $i<@buffer; $i++) {
5470: if (($firstline == -1) && ($buffer[$i] =~ m/<div\sclass="normalDiv"><div\sclass="normalSpan">/)) {
5471: $firstline = $i;
5472: $buffer[$i] = substr($buffer[$i],index($buffer[$i],'"normalSpan"')+13);
5473: }
5474: if (($firstline > -1) && ($buffer[$i] =~ m-<p></p></div></div>-)) {
5475: $buffer[$i] = substr($buffer[$i],0,index($buffer[$i],'<p></p></div></div>'));
5476: $lastline = $i;
1.1 raeburn 5477: }
5478: }
5479: }
1.2 raeburn 5480: open(FILE,">$destdir/resfiles/$res.html");
5481: push @{$resrcfiles}, "$res.html";
5482: print FILE qq|<html>
5483: <head>
5484: <title>$title</title>
5485: </head>
5486: <body bgcolor='#ffffff'>
5487: |;
5488: unless ($title eq '') {
5489: print FILE qq|<b>$title</b><br/>\n|;
5490: }
5491: unless ($$settings{subtitle} eq '') {
5492: print FILE qq|$$settings{subtitle}<br/>\n|;
5493: }
5494: print FILE "<br/>\n";
5495: if ($type eq "LINK") {
5496: foreach my $link (@{$$settings{links}}) {
5497: print FILE qq|<a href="$link">$link</a><br/>\n|;
5498: }
5499: } elsif ($type eq "PAGE") {
5500: if ($firstline > -1) {
5501: for (my $i=$firstline; $i<=$lastline; $i++) {
5502: print FILE "$buffer[$i]\n";
5503: }
5504: }
5505: }
5506: print FILE qq|
5507: </body>
5508: </html>|;
5509: close(FILE);
1.1 raeburn 5510: }
5511:
1.15 raeburn 5512: # ---------------------------------------------------------------- WebCT content
5513: sub webct4_content {
5514: my ($res,$docroot,$destdir,$settings,$dom,$user,$type,$title,$resrcfiles) = @_;
1.42 raeburn 5515: if (defined($$settings{url})) {
5516: if (!open(FILE,">$destdir/resfiles/$res.html")) {
5517: &Apache::lonnet::logthis("IMS import error: Cannot open file - $destdir/resfiles/$res.html - $!");
5518: } else {
5519: push(@{$resrcfiles}, "$res.html");
5520: my $linktag = qq|<a href="$$settings{url}"|;
1.15 raeburn 5521: if ($title ne '') {
5522: $linktag .= qq|>$title</a>|;
5523: } else {
5524: $linktag .= qq|>$$settings{url}|;
5525: }
1.42 raeburn 5526: print FILE qq|<html>
1.15 raeburn 5527: <head>
5528: <title>$title</title>
5529: </head>
5530: <body bgcolor='#ffffff'>
5531: $linktag
5532: </body>
5533: </html>|;
1.42 raeburn 5534: close(FILE);
5535: }
1.15 raeburn 5536: }
5537: }
5538:
1.30 raeburn 5539: sub process_html {
5540: my ($text,$caller,$html_cond,$context,$res,$dirname,$cdom,$cnum,$docroot,$destdir) = @_;
1.33 raeburn 5541: my $pathstart;
5542: if ($context eq 'CSTR') {
5543: $pathstart = '../..';
5544: } else {
5545: $pathstart = $dirname;
5546: }
1.30 raeburn 5547: if ($caller eq 'bb5') {
5548: if ($html_cond eq 'true') {
5549: $$text = &HTML::Entities::decode($$text);
5550: }
5551: } elsif ($caller eq 'bb6') {
5552: if ($html_cond eq 'HTML') {
5553: $$text = &HTML::Entities::decode($$text);
5554: }
5555: }
5556: if ($$text =~ m#<img src=['"]?(https?://[^\s]+/)([^/\s\'"]+)['"]?[^>]*>#) {
5557: if (&retrieve_image($context,$res,$dirname,$cdom,$cnum,$docroot,$destdir,$1,$2) eq 'ok') {
1.33 raeburn 5558: $$text =~ s#(<img src=['"]?)(https?://[^\s]+/)([^/\s'"]+)(['"]?[^>]*>)#$1$pathstart/resfiles/$res/webimages/$3$4#g;
1.30 raeburn 5559: }
5560: }
5561: $$text =~ s#(<img src=[^>]+)/*>#$1 />#gi;
5562: $$text =~ s#<br>#<br />#g;
5563: return;
5564: }
5565:
5566: sub add_images_links {
1.33 raeburn 5567: my ($type,$context,$settings,$id,$dirname,$res) = @_;
5568: my ($image,$imglink,$url,$pathstart);
5569: if ($context eq 'CSTR') {
5570: $pathstart = '../..';
5571: } else {
5572: $pathstart = $dirname;
5573: }
1.30 raeburn 5574: if ((defined($$settings{$id}{$type}{image})) && ($$settings{$id}{$type}{image} ne '')) {
5575: if ( $$settings{$id}{$type}{style} eq 'Inline' ) {
1.33 raeburn 5576: $image = qq|<br /><img src="$pathstart/resfiles/$res/$$settings{$id}{$type}{image}" alt="$$settings{$id}{$type}{label}"/><br />|;
1.30 raeburn 5577: } else {
1.33 raeburn 5578: $imglink = qq|<br /><a href="$pathstart/resfiles/$res/$$settings{$id}{$type}{image}">$$settings{$id}{$type}{label}</a><br />|;
1.30 raeburn 5579: }
5580: }
5581: if ((defined($$settings{$id}{$type}{link})) && ($$settings{$id}{$type}{link} ne '' )) {
5582: $url = qq|<br /><a href="$$settings{$id}{$type}{link}">$$settings{$id}{$type}{linkname}</a><br />|;
5583: }
5584: return $image.$imglink.$url;
5585: }
5586:
5587: sub remove_html {
5588: my ($choice_text) = @_;
5589: return $choice_text;
5590: }
5591:
5592:
1.1 raeburn 5593: 1;
5594: __END__
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to imsprocessor.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / imspackages