1: # The LearningOnline Network
2: # Third step to clean a file.
3: #
4: # $Id: post_xml.pm,v 1.11 2016/11/10 21:53:56 damieng Exp $
5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
28: ###
29:
30: #!/usr/bin/perl
31:
32: package Apache::post_xml;
33:
34: use strict;
35: use utf8;
36: use warnings;
37:
38: use File::Basename;
39: use File::Temp qw/ tempfile /;
40: use Cwd 'abs_path';
41: use XML::LibXML;
42: use HTML::TokeParser; # used to parse sty files
43: use Tie::IxHash; # for ordered hashes
44: use tth;
45: use Apache::html_to_xml;
46:
47: no warnings 'recursion'; # yes, fix_paragraph is using heavy recursion, I know
48:
49: # these are constants
50: my @block_elements = ('parameter','location','answer','foil','image','polygon','rectangle','text','conceptgroup','itemgroup','item','label','data','function','array','unit','answergroup','functionplotresponse','functionplotruleset','functionplotelements','functionplotcustomrule','essayresponse','hintpart','formulahint','numericalhint','reactionhint','organichint','optionhint','radiobuttonhint','stringhint','customhint','mathhint','formulahintcondition','numericalhintcondition','reactionhintcondition','organichintcondition','optionhintcondition','radiobuttonhintcondition','stringhintcondition','customhintcondition','mathhintcondition','imageresponse','foilgroup','datasubmission','textfield','hiddensubmission','radiobuttonresponse','rankresponse','matchresponse','import','style','script','window','block','library','notsolved','part','postanswerdate','preduedate','problem','problemtype','randomlabel','bgimg','labelgroup','randomlist','solved','while','tex','print','web','gnuplot','curve','Task','IntroParagraph','ClosingParagraph','Question','QuestionText','Setup','Instance','InstanceText','Criteria','CriteriaText','GraderNote','languageblock','instructorcomment','dataresponse','togglebox','standalone','comment','drawimage','allow','displayduedate','displaytitle','responseparam','organicstructure','scriptlib','parserlib','drawoptionlist','spline','backgroundplot','plotobject','plotvector','drawvectorsum','functionplotrule','functionplotvectorrule','functionplotvectorsumrule','axis','key','xtics','ytics','title','xlabel','ylabel','hiddenline','dtm');
51: my @inline_like_block = ('stringresponse','optionresponse','numericalresponse','formularesponse','mathresponse','organicresponse','reactionresponse','customresponse','externalresponse', 'hint', 'hintgroup','translated','lang'); # inline elements treated like blocks for pretty print and some other things
52: my @responses = ('stringresponse','optionresponse','numericalresponse','formularesponse','mathresponse','organicresponse','reactionresponse','customresponse','externalresponse','essayresponse','radiobuttonresponse','matchresponse','rankresponse','imageresponse','functionplotresponse');
53: my @block_html = ('html','head','body','section','h1','h2','h3','h4','h5','h6','div','p','ul','ol','li','table','tbody','tr','td','th','dl','dt','dd','pre','noscript','hr','address','blockquote','object','applet','embed','map','form','fieldset','iframe','center','frameset');
54: my @no_newline_inside = ('import','parserlib','scriptlib','data','function','label','xlabel','ylabel','tic','text','rectangle','image','title','h1','h2','h3','h4','h5','h6','li','td','p');
55: my @preserve_elements = ('script','answer','pre','style');
56: my @accepting_style = ('section','h1','h2','h3','h4','h5','h6','div','p','li','td','th','dt','dd','pre','blockquote');
57: my @latex_math = ('\alpha', '\theta', '\omicron', '\tau', '\beta', '\vartheta', '\pi', '\upsilon', '\gamma', '\gamma', '\varpi', '\phi', '\delta', '\kappa', '\rho', '\varphi', '\epsilon', '\lambda', '\varrho', '\chi', '\varepsilon', '\mu', '\sigma', '\psi', '\zeta', '\nu', '\varsigma', '\omega', '\eta', '\xi',
58: '\Gamma', '\Lambda', '\Sigma', '\Psi', '\Delta', '\Xi', '\Upsilon', '\Omega', '\Theta', '\Pi', '\Phi',
59: '\pm', '\cap', '\diamond', '\oplus', '\mp', '\cup', '\bigtriangleup', '\ominus', '\times', '\uplus', '\bigtriangledown', '\otimes', '\div', '\sqcap', '\triangleleft', '\oslash', '\ast', '\sqcup', '\triangleright', '\odot', '\star', '\vee', '\lhd$', '\bigcirc', '\circ', '\wedge', '\rhd$', '\dagger', '\bullet', '\setminus', '\unlhd$', '\ddagger', '\cdot', '\wr', '\unrhd$', '\amalg', '+', '-',
60: '\leq', '\geq', '\equiv', '\models', '\prec', '\succ', '\sim', '\perp', '\preceq', '\succeq', '\simeq', '\mid', '\ll', '\gg', '\asymp', '\parallel', '\subset', '\supset', '\approx', '\bowtie', '\subseteq', '\supseteq', '\cong', '\Join$', '\sqsubset$', '\sqsupset$', '\neq', '\smile', '\sqsubseteq', '\sqsupseteq', '\doteq', '\frown', '\in', '\ni', '\propto', '\vdash', '\dashv',
61: '\colon', '\ldotp', '\cdotp',
62: '\leftarrow', '\longleftarrow', '\uparrow', '\Leftarrow', '\Longleftarrow', '\Uparrow', '\rightarrow', '\longrightarrow', '\downarrow', '\Rightarrow', '\Longrightarrow', '\Downarrow', '\leftrightarrow', '\longleftrightarrow', '\updownarrow', '\Leftrightarrow', '\Longleftrightarrow', '\Updownarrow', '\mapsto', '\longmapsto', '\nearrow', '\hookleftarrow', '\hookrightarrow', '\searrow', '\leftharpoonup', '\rightharpoonup', '\swarrow', '\leftharpoondown', '\rightharpoondown', '\nwarrow', '\rightleftharpoons', '\leadsto$',
63: '\ldots', '\cdots', '\vdots', '\ddots', '\aleph', '\prime', '\forall', '\infty', '\hbar', '\emptyset', '\exists', '\Box$', '\imath', '\nabla', '\neg', '\Diamond$', '\jmath', '\surd', '\flat', '\triangle', '\ell', '\top', '\natural', '\clubsuit', '\wp', '\bot', '\sharp', '\diamondsuit', '\Re', '\|', '\backslash', '\heartsuit', '\Im', '\angle', '\partial', '\spadesuit', '\mho$',
64: '\sum', '\bigcap', '\bigodot', '\prod', '\bigcup', '\bigotimes', '\coprod', '\bigsqcup', '\bigoplus', '\int', '\bigvee', '\biguplus', '\oint', '\bigwedge',
65: '\arccos', '\cos', '\csc', '\exp', '\ker', '\limsup', '\min', '\sinh', '\arcsin', '\cosh', '\deg', '\gcd', '\lg', '\ln', '\Pr', '\sup', '\arctan', '\cot', '\det', '\hom', '\lim', '\log', '\sec', '\tan', '\arg', '\coth', '\dim', '\inf', '\liminf', '\max', '\sin', '\tanh',
66: '\uparrow', '\Uparrow', '\downarrow', '\Downarrow', '\updownarrow', '\Updownarrow', '\lfloor', '\rfloor', '\lceil', '\rceil', '\langle', '\rangle', '\backslash',
67: '\rmoustache', '\lmoustache', '\rgroup', '\lgroup', '\arrowvert', '\Arrowvert', '\bracevert',
68: '\hat{', '\acute{', '\bar{', '\dot{', '\breve{', '\check{', '\grave{', '\vec{', '\ddot{', '\tilde{',
69: '\widetilde{', '\widehat{', '\overleftarrow{', '\overrightarrow{', '\overline{', '\underline{', '\overbrace{', '\underbrace{', '\sqrt{', '\sqrt[', '\frac{'
70: );
71: # list of elements that can contain style elements:
72: my @containing_styles = ('library','problem',@responses,'foil','item','text','hintgroup','hintpart','label','part','preduedate','postanswerdate','solved','notsolved','block','while','web','standalone','problemtype','languageblock','translated','lang','window','windowlink','togglebox','instructorcomment','body','section','div','p','li','dd','td','th','blockquote','object','applet','video','audio','canvas','fieldset','button',
73: 'span','strong','em','b','i','sup','sub','code','kbd','samp','tt','ins','del','var','small','big','u','font');
74: my @html_styles = ('span', 'strong', 'em' , 'b', 'i', 'sup', 'sub', 'tt', 'var', 'small', 'big', 'u');
75:
76: my $warnings; # 1 = print warnings
77:
78:
79: # Parses the XML document and fixes many things to turn it into a document matching the schema.
80: # @param {reference} textref - reference to the text of the document
81: # @param {string} file_path - path of the file being processed (we only extract the directory path from it)
82: # @param {string} res_dir - path of res directory parent (without the / at the end)
83: # @param {boolean} warn - 1 to print warnings, 0 otherwise
84: # @returns the text of the document as a byte string.
85: sub post_xml {
86: my ($textref, $file_path, $res_dir, $warn) = @_;
87: $warnings = $warn;
88:
89: my $dom_doc = XML::LibXML->load_xml(string => $textref);
90:
91: my $root = fix_structure($dom_doc);
92:
93: remove_elements($root, ['startouttext','startoutext','startottext','startouttex','startouttect','atartouttext','starouttext','starttextout','starttext','starttextarea','endouttext','endoutext','endoutttext','endouttxt','endouutext','ednouttext','endouttex','endoouttext','endouttest','endtextout','endtextarea','startpartmarker','endpartmarker','basefont','x-claris-tagview','x-claris-window','x-sas-window']);
94:
95: remove_empty_attributes($root);
96:
97: fix_attribute_case($root);
98:
99: replace_m($root);
100:
101: my @all_block = (@block_elements, @block_html);
102: add_sty_blocks($file_path, $res_dir, $root, \@all_block); # must come before the subs using @all_block
103:
104: fix_block_styles($root, \@all_block);
105: $root->normalize();
106:
107: fix_fonts($root, \@all_block);
108:
109: replace_u($root);
110:
111: remove_bad_cdata_sections($root);
112:
113: add_cdata_sections($root);
114:
115: fix_style_element($root);
116:
117: fix_tables($root);
118:
119: fix_lists($root);
120:
121: fix_wrong_name_for_img($root); # should be before replace_deprecated_attributes_by_css
122:
123: replace_deprecated_attributes_by_css($root);
124:
125: replace_center($root, \@all_block); # must come after replace_deprecated_attributes_by_css
126:
127: replace_nobr($root);
128:
129: remove_useless_notsolved($root);
130:
131: fix_comments($root);
132:
133: fix_paragraphs_inside($root, \@all_block);
134:
135: remove_empty_style($root);
136:
137: fix_empty_lc_elements($root);
138:
139: reduce_empty_p($root);
140:
141: lowercase_attribute_values($root);
142:
143: replace_numericalresponse_unit_attribute($root);
144:
145: replace_functions_by_elements($root);
146:
147: pretty($root, \@all_block);
148:
149: replace_tm_dtm($root);
150:
151: return $dom_doc->toString(); # byte string !
152: }
153:
154: sub fix_structure {
155: my ($doc) = @_;
156: # the root element has already been added in pre_xml
157: my $root = $doc->documentElement;
158: # inside the root, replace html, problem and library elements by their content
159: my @toreplace = ('html','problem','library','Task');
160: foreach my $name (@toreplace) {
161: my @elements = $root->getElementsByTagName($name);
162: foreach my $element (@elements) {
163: replace_by_children($element);
164: }
165: }
166: # insert all link and style elements inside a new head element
167: my $current_node = undef;
168: my @heads = $doc->getElementsByTagName('head');
169: my @links = $doc->getElementsByTagName('link');
170: my @styles = $doc->getElementsByTagName('style');
171: my @titles = $doc->getElementsByTagName('title');
172: if (scalar(@titles) > 0) {
173: # NOTE: there is a title element in gnuplot, not to be confused with the one inside HTML head
174: for (my $i=0; $i<scalar(@titles); $i++) {
175: my $title = $titles[$i];
176: my $found_gnuplot = 0;
177: my $ancestor = $title->parentNode;
178: while (defined $ancestor) {
179: if ($ancestor->nodeName eq 'gnuplot') {
180: $found_gnuplot = 1;
181: last;
182: }
183: $ancestor = $ancestor->parentNode;
184: }
185: if ($found_gnuplot) {
186: splice(@titles, $i, 1);
187: $i--;
188: }
189: }
190: }
191: if (scalar(@heads) > 0 || scalar(@titles) > 0 || scalar(@links) > 0 || scalar(@styles) > 0) {
192: my $htmlhead = $doc->createElement('head');
193: foreach my $head (@heads) {
194: my $next;
195: for (my $child=$head->firstChild; defined $child; $child=$next) {
196: $next = $child->nextSibling;
197: $head->removeChild($child);
198: if ($child->nodeType != XML_ELEMENT_NODE ||
199: string_in_array(['title','script','style','meta','link','import','base'], $child->nodeName)) {
200: $htmlhead->appendChild($child);
201: } else {
202: # this should not be in head
203: insert_after_or_first($root, $child, $current_node);
204: }
205: }
206: $head->parentNode->removeChild($head);
207: }
208: foreach my $child (@titles, @links, @styles) {
209: $child->parentNode->removeChild($child);
210: $htmlhead->appendChild($child);
211: }
212: insert_after_or_first($root, $htmlhead, $current_node);
213: $current_node = $htmlhead;
214: }
215: # body
216: my $htmlbody = undef;
217: my @bodies = $doc->getElementsByTagName('body');
218: if (scalar(@bodies) > 0) {
219: # TODO: fix content and position of body elements
220: if ($root->nodeName eq 'problem') {
221: foreach my $body (@bodies) {
222: replace_by_children($body);
223: }
224: }
225: }
226: # add all the meta elements afterwards when they are LON-CAPA meta. Remove all HTML meta.
227: my @meta_names = ('abstract','author','authorspace','avetries','avetries_list','clear','comefrom','comefrom_list','copyright','correct','count','course','course_list','courserestricted','creationdate','dependencies','depth','difficulty','difficulty_list','disc','disc_list','domain','end','field','firstname','generation','goto','goto_list','groupname','helpful','highestgradelevel','hostname','id','keynum','keywords','language','lastname','lastrevisiondate','lowestgradelevel','middlename','mime','modifyinguser','notes','owner','permanentemail','scope','sequsage','sequsage_list','standards','start','stdno','stdno_list','subject','technical','title','url','username','value','version');
228: my @metas = $doc->getElementsByTagName('meta');
229: foreach my $meta (@metas) {
230: $meta->parentNode->removeChild($meta);
231: my $name = $meta->getAttribute('name');
232: my $content = $meta->getAttribute('content');
233: if (defined $name && defined $content && string_in_array(\@meta_names, lc($name))) {
234: my $lcmeta = $doc->createElement('meta');
235: $lcmeta->setAttribute('name', lc($name));
236: $lcmeta->setAttribute('content', $content);
237: insert_after_or_first($root, $lcmeta, $current_node);
238: $current_node = $lcmeta;
239: }
240: }
241: return($root);
242: }
243:
244: # insert the new child under parent after the reference child, or as the first child if the reference child is not defined
245: sub insert_after_or_first {
246: my ($parent, $newchild, $refchild) = @_;
247: if (defined $refchild) {
248: $parent->insertAfter($newchild, $refchild);
249: } elsif (defined $parent->firstChild) {
250: $parent->insertBefore($newchild, $parent->firstChild);
251: } else {
252: $parent->appendChild($newchild);
253: }
254: }
255:
256: # removes all elements with given names inside the node, but keep the content
257: sub remove_elements {
258: my ($node, $to_remove) = @_;
259: my $nextChild;
260: for (my $child=$node->firstChild; defined $child; $child=$nextChild) {
261: $nextChild = $child->nextSibling;
262: my $type = $node->nodeType;
263: if ($type == XML_ELEMENT_NODE) {
264: if (string_in_array($to_remove, $child->nodeName)) {
265: my $first_non_white = $child->firstChild;
266: if (defined $first_non_white && $first_non_white->nodeType == XML_TEXT_NODE &&
267: $first_non_white->nodeValue =~ /^\s*$/) {
268: $first_non_white = $first_non_white->nextSibling;
269: }
270: if (defined $first_non_white) {
271: $nextChild = $first_non_white;
272: replace_by_children($child);
273: } else {
274: $node->removeChild($child);
275: }
276: } else {
277: remove_elements($child, $to_remove);
278: }
279: }
280: }
281: }
282:
283: # removes some attributes that have an invalid empty value
284: sub remove_empty_attributes {
285: my ($root) = @_;
286: my $doc = $root->ownerDocument;
287: # this list is based on validation errors in the MSU subset (it could be more complete if it was based on the schema)
288: my @attributes = (
289: ['curve', ['pointsize']],
290: ['foil', ['location']],
291: ['foilgroup', ['checkboxoptions', 'options', 'texoptions']],
292: ['gnuplot', ['pattern', 'texwidth']],
293: ['img', ['height', 'texheight', 'texwidth', 'texwrap', 'width']],
294: ['import', ['importmode']],
295: ['optionresponse', ['max']],
296: ['organicstructure', ['options']],
297: ['radiobuttonresponse', ['max']],
298: ['randomlabel', ['height', 'texwidth', 'width']],
299: ['stringresponse', ['type']],
300: ['textline', ['size']],
301: );
302: foreach my $element_attributes (@attributes) {
303: my $element_name = $element_attributes->[0];
304: my $attribute_names = $element_attributes->[1];
305: my @elements = $doc->getElementsByTagName($element_name);
306: foreach my $element (@elements) {
307: foreach my $attribute_name (@$attribute_names) {
308: my $value = $element->getAttribute($attribute_name);
309: if (defined $value && $value =~ /^\s*$/) {
310: $element->removeAttribute($attribute_name);
311: }
312: }
313: }
314: }
315: }
316:
317: # fixes the case for a few attributes that are not all lowercase
318: # (the HTML parser used in html_to_xml turns everything lowercase, which is a good thing in general)
319: sub fix_attribute_case {
320: my ($root) = @_;
321: my $doc = $root->ownerDocument;
322: my @attributes = (
323: ['labelgroup', ['TeXsize']],
324: ['h1', ['TeXsize']],
325: ['h2', ['TeXsize']],
326: ['h3', ['TeXsize']],
327: ['h4', ['TeXsize']],
328: ['h5', ['TeXsize']],
329: ['h6', ['TeXsize']],
330: # font and basefont have a TeXsize but will be removed
331: ['optionresponse', ['TeXlayout']],
332: ['itemgroup', ['TeXitemgroupwidth']],
333: ['Task', ['OptionalRequired']],
334: ['Question', ['OptionalRequired','Mandatory']],
335: ['Instance', ['OptionalRequired','Disabled']],
336: ['Criteria', ['Mandatory']],
337: ['table', ['TeXwidth','TeXtheme']],
338: ['td', ['TeXwidth']],
339: ['th', ['TeXwidth']],
340: ['img', ['TeXwidth','TeXheight','TeXwrap']],
341: );
342: foreach my $element_attributes (@attributes) {
343: my $element_name = $element_attributes->[0];
344: my $attribute_names = $element_attributes->[1];
345: my @elements = $doc->getElementsByTagName($element_name);
346: foreach my $element (@elements) {
347: foreach my $attribute_name (@$attribute_names) {
348: my $value = $element->getAttribute(lc($attribute_name));
349: if (defined $value) {
350: $element->removeAttribute(lc($attribute_name));
351: $element->setAttribute($attribute_name, $value);
352: }
353: }
354: }
355: }
356: }
357:
358: # Replaces m by HTML, tm and/or dtm (which will be replaced by <m> later, but they are useful
359: # to know if the element is a block element or not).
360: # m might contain non-math LaTeX, while tm and dtm may only contain math.
361: sub replace_m {
362: my ($root) = @_;
363: my $doc = $root->ownerDocument;
364: # search for variable declarations
365: my @variables = ();
366: my @scripts = $root->getElementsByTagName('script');
367: foreach my $script (@scripts) {
368: my $type = $script->getAttribute('type');
369: if (defined $type && $type eq 'loncapa/perl') {
370: if (defined $script->firstChild && $script->firstChild->nodeType == XML_TEXT_NODE) {
371: my $text = $script->firstChild->nodeValue;
372: # NOTE: we are not interested in replacing "@value", only "$value"
373: # this regexp is for " $a = ..." and " $a[...] = ..."
374: while ($text =~ /^[ \t]*\$([a-zA-Z_0-9]+)(?:\[[^\]]+\])?[ \t]*=/gm) {
375: if (!string_in_array(\@variables, $1)) {
376: push(@variables, $1);
377: }
378: }
379: # this regexp is for "...; $a = ..." and "...; $a[...] = ..."
380: while ($text =~ /^[^'"\/;]+;[ \t]*\$([a-zA-Z_0-9]+)(?:\[[^\]]+\])?[ \t]*=/gm) {
381: if (!string_in_array(\@variables, $1)) {
382: push(@variables, $1);
383: }
384: }
385: # this regexp is for " @a = ..."
386: while ($text =~ /^[ \t]*\@([a-zA-Z_0-9]+)[ \t]*=/gm) {
387: if (!string_in_array(\@variables, $1)) {
388: push(@variables, $1);
389: }
390: }
391: # this regexp is for " ($a, $b, $c) = ..."
392: my @matches = ($text =~ /^[ \t]*\([ \t]*\$([a-zA-Z_0-9]+)(?:[ \t]*,[ \t]*\$([a-zA-Z_0-9]+))*[ \t]*\)[ \t]*=/gm);
393: foreach my $match (@matches) {
394: if (!defined $match) {
395: next; # not sure why it happens, but it does
396: }
397: if (!string_in_array(\@variables, $match)) {
398: push(@variables, $match);
399: }
400: }
401: # and this one is for "push @a"
402: while ($text =~ /^[ \t]*push @([a-zA-Z_0-9]+)[ \t,]*/gm) {
403: if (!string_in_array(\@variables, $1)) {
404: push(@variables, $1);
405: }
406: }
407: # use the opportunity to report usage of <m> in Perl scripts
408: if ($text =~ /^[^#].*<m[ >]/m) {
409: if ($warnings) {
410: print "WARNING: <m> is used in a script, it should be converted by hand\n";
411: }
412: }
413: }
414: }
415: }
416: my @ms = $root->getElementsByTagName('m');
417: foreach my $m (@ms) {
418: if (!defined $m->firstChild) {
419: $m->parentNode->removeChild($m);
420: next;
421: }
422: if (defined $m->firstChild->nextSibling || $m->firstChild->nodeType != XML_TEXT_NODE) {
423: if ($warnings) {
424: print "WARNING: m value is not simple text\n";
425: }
426: next;
427: }
428: my $text = $m->firstChild->nodeValue;
429: my $text_before_variable_replacement = $text;
430: my $var_key1 = 'dfhg3df54hg65hg4';
431: my $var_key2 = 'dfhg654d6f5g4h5f';
432: my $eval = defined $m->getAttribute('eval') && $m->getAttribute('eval') eq 'on';
433: if ($eval) {
434: # replace variables
435: foreach my $variable (@variables) {
436: my $replacement = $var_key1.$variable.$var_key2;
437: $text =~ s/\$$variable(?![a-zA-Z])/$replacement/ge;
438: $text =~ s/\$\{$variable\}/$replacement/ge;
439: }
440: }
441: # check if the expression is enclosed in math separators: $ $$ \( \) \[ \]
442: # if so, replace the whole node by dtm or tm
443: my $new_text;
444: my $new_node_name;
445: if ($text =~ /^\s*\$\$([^\$]*)\$\$\s*$/) {
446: $new_node_name = 'dtm';
447: $new_text = $1;
448: } elsif ($text =~ /^\s*\\\[(.*)\\\]\s*$/s) {
449: $new_node_name = 'dtm';
450: $new_text = $1;
451: } elsif ($text =~ /^\s*\$([^\$]*)\$\s*$/) {
452: $new_node_name = 'tm';
453: $new_text = $1;
454: } elsif ($text =~ /^\s*\\\((.*)\\\)\s*$/s) {
455: $new_node_name = 'tm';
456: $new_text = $1;
457: }
458: if (defined $new_node_name) {
459: if ($eval) {
460: foreach my $variable (@variables) {
461: my $replacement = $var_key1.$variable.$var_key2;
462: $new_text =~ s/$replacement([a-zA-Z])/\${$variable}$1/g;
463: $new_text =~ s/$replacement/\$$variable/g;
464: }
465: }
466: my $new_node = $doc->createElement($new_node_name);
467: if ($eval) {
468: $new_node->setAttribute('eval', 'on');
469: }
470: $new_node->appendChild($doc->createTextNode($new_text));
471: $m->parentNode->replaceChild($new_node, $m);
472: next;
473: }
474: if ($text !~ /\$|\\\(|\\\)|\\\[|\\\]/) {
475: # there are no math separators inside
476: # try to guess if this is meant as math
477: my $found_math = 0;
478: foreach my $symbol (@latex_math) {
479: if (index($text, $symbol) != -1) {
480: $found_math = 1;
481: last;
482: }
483: }
484: if ($found_math) {
485: # interpret the whole text as LaTeX inline math
486: my $new_node = $doc->createElement('tm');
487: if ($eval) {
488: $new_node->setAttribute('eval', 'on');
489: }
490: $new_node->appendChild($doc->createTextNode($text_before_variable_replacement));
491: $m->parentNode->replaceChild($new_node, $m);
492: next;
493: }
494: # no math symbol found, we will convert the text with tth
495: }
496:
497: # there are math separators inside, even after hiding variables, or there was no math symbol
498:
499: # hide math parts inside before running tth
500: my $math_key1 = '#ghjgdh5hg45gf';
501: my $math_key2 = '#';
502: my @maths = ();
503: my @separators = (['$$','$$'], ['\\(','\\)'], ['\\[','\\]'], ['$','$']);
504: foreach my $seps (@separators) {
505: my $sep1 = $seps->[0];
506: my $sep2 = $seps->[1];
507: my $pos1 = index($text, $sep1);
508: if ($pos1 == -1) {
509: next;
510: }
511: my $pos2 = index($text, $sep2, $pos1+length($sep1));
512: while ($pos1 != -1 && $pos2 != -1) {
513: my $replace = substr($text, $pos1, $pos2+length($sep2)-$pos1);
514: push(@maths, $replace);
515: my $by = $math_key1.scalar(@maths).$math_key2;
516: $text = substr($text, 0, $pos1).$by.substr($text, $pos2+length($sep2));
517: $pos1 = index($text, $sep1);
518: if ($pos1 != -1) {
519: $pos2 = index($text, $sep2, $pos1+length($sep1));
520: }
521: }
522: }
523: # get HTML as text from tth
524: my $html_text = tth($text);
525: # replace math by replacements
526: for (my $i=0; $i < scalar(@maths); $i++) {
527: my $math = $maths[$i];
528: $math =~ s/&/&/g;
529: $math =~ s/</</g;
530: $math =~ s/>/>/g;
531: if ($math =~ /^\$\$(.*)\$\$$/s) {
532: $math = '<dtm>'.$1.'</dtm>';
533: } elsif ($math =~ /^\\\[(.*)\\\]$/s) {
534: $math = '<dtm>'.$1.'</dtm>';
535: } elsif ($math =~ /^\\\((.*)\\\)$/s) {
536: $math = '<tm>'.$1.'</tm>';
537: } elsif ($math =~ /^\$(.*)\$$/s) {
538: $math = '<tm>'.$1.'</tm>';
539: }
540: my $replace = $math_key1.($i+1).$math_key2;
541: $html_text =~ s/$replace/$math/;
542: }
543: # replace variables if necessary
544: if ($eval) {
545: foreach my $variable (@variables) {
546: my $replacement = $var_key1.$variable.$var_key2;
547: $html_text =~ s/$replacement([a-zA-Z])/\${$variable}$1/g;
548: $html_text =~ s/$replacement/\$$variable/g;
549: }
550: }
551: my $fragment = html_to_dom($html_text);
552: $doc->adoptNode($fragment);
553: $m->parentNode->replaceChild($fragment, $m);
554:
555: }
556: }
557:
558: # Returns the HTML equivalent of LaTeX input, using tth
559: sub tth {
560: my ($text) = @_;
561: my $output = &tth::tth($text);
562: my $errorstring = &tth::ttherror();
563: if ($errorstring) {
564: die $errorstring;
565: }
566: # hopefully the temp file will not be removed before this point (otherwise we should use unlink_on_destroy 0)
567: $output =~ s/^\s*|\s*$//;
568: $output =~ s/<div class="p"><!----><\/div>/<br\/>/; # why is tth using such ugly markup for \newline ?
569: return $output;
570: }
571:
572: # transform simple HTML into a DOM fragment (which will need to be adopted by the document)
573: sub html_to_dom {
574: my ($text) = @_;
575: $text = '<root>'.$text.'</root>';
576: my $textref = Apache::html_to_xml::html_to_xml(\$text);
577: utf8::upgrade($$textref); # otherwise the XML parser fails when the HTML parser turns into a character
578: my $dom_doc = XML::LibXML->load_xml(string => $textref);
579: my $root = $dom_doc->documentElement;
580: remove_empty_style($root);
581: my $fragment = $dom_doc->createDocumentFragment();
582: my $next;
583: for (my $n=$root->firstChild; defined $n; $n=$next) {
584: $next = $n->nextSibling;
585: $root->removeChild($n);
586: $fragment->appendChild($n);
587: }
588: return($fragment);
589: }
590:
591: # Use the linked sty files to guess which newly defined elements should be considered blocks.
592: # Also adds to @containing_styles the sty elements that contain styles.
593: # @param {string} fn - the file path (we only extract the directory path from it)
594: # @param {string} res_dir - path of res directory parent (without the / at the end)
595: # @param {Element} root - the root element
596: sub add_sty_blocks {
597: my ($fn, $res_dir, $root, $all_block) = @_;
598: my $doc = $root->ownerDocument;
599: my @parserlibs = $doc->getElementsByTagName('parserlib');
600: my @libs = ();
601: foreach my $parserlib (@parserlibs) {
602: if (defined $parserlib->firstChild && $parserlib->firstChild->nodeType == XML_TEXT_NODE) {
603: my $value = $parserlib->firstChild->nodeValue;
604: $value =~ s/^\s+|\s+$//g;
605: if ($value ne '') {
606: push(@libs, $value);
607: }
608: }
609: }
610: my ($name, $path, $suffix) = fileparse($fn);
611: foreach my $sty (@libs) {
612: if (substr($sty, 0, 1) eq '/') {
613: $sty = $res_dir.$sty;
614: } else {
615: $sty = $path.$sty;
616: }
617: my $new_elements = parse_sty($sty, $all_block);
618: better_guess($root, $new_elements, $all_block);
619: my $new_blocks = $new_elements->{'block'};
620: my $new_inlines = $new_elements->{'inline'};
621: push(@$all_block, @{$new_blocks});
622: #push(@inlines, @{$new_inlines}); # we are not using a list of inline elements at this point
623: }
624: }
625:
626: ##
627: # Parses a sty file and returns lists of block and inline elements.
628: # @param {string} fn - the file path
629: ##
630: sub parse_sty {
631: my ($fn, $all_block) = @_;
632: my @blocks = ();
633: my @inlines = ();
634: my $p = HTML::TokeParser->new($fn);
635: if (! $p) {
636: die "post_xml.pl: parse_sty: Error reading $fn\n";
637: }
638: $p->empty_element_tags(1);
639: my $in_definetag = 0;
640: my $in_render = 0;
641: my %newtags = ();
642: my $newtag = '';
643: my $is_block = 0;
644: while (my $token = $p->get_token) {
645: if ($token->[0] eq 'S') {
646: my $tag = lc($token->[1]);
647: if ($tag eq 'definetag') {
648: $in_definetag = 1;
649: $is_block = 0;
650: my $attributes = $token->[2];
651: $newtag = $attributes->{'name'};
652: if (substr($newtag, 0, 1) eq '/') {
653: $newtag = substr($newtag, 1);
654: }
655: } elsif ($in_definetag && $tag eq 'render') {
656: $in_render = 1;
657: $is_block = 0;
658: } elsif ($in_render) {
659: if (string_in_array($all_block, $tag)) {
660: $is_block = 1;
661: }
662: }
663: } elsif ($token->[0] eq 'E') {
664: my $tag = lc($token->[1]);
665: if ($tag eq 'definetag') {
666: $in_definetag = 0;
667: if (defined $newtags{$newtag}) {
668: $newtags{$newtag} = $newtags{$newtag} || $is_block;
669: } else {
670: $newtags{$newtag} = $is_block;
671: }
672: } elsif ($in_definetag && $tag eq 'render') {
673: $in_render = 0;
674: }
675: }
676: }
677: foreach $newtag (keys(%newtags)) {
678: if ($newtags{$newtag} == 1) {
679: push(@blocks, $newtag);
680: } else {
681: push(@inlines, $newtag);
682: }
683: }
684: return {'block'=>\@blocks, 'inline'=>\@inlines};
685: }
686:
687: ##
688: # Marks as block the elements that contain block elements in the input file.
689: # Also adds to @containing_styles the sty elements that contain styles.
690: # @param {string} fn - the file path
691: # @param {Hash<string,Array>} new_elements - contains arrays in 'block' and 'inline'
692: ##
693: sub better_guess {
694: my ($root, $new_elements, $all_block) = @_;
695: my $new_blocks = $new_elements->{'block'};
696: my $new_inlines = $new_elements->{'inline'};
697:
698: my @change = (); # change these elements from inline to block
699: foreach my $tag (@{$new_inlines}) {
700: my @nodes = $root->getElementsByTagName($tag);
701: NODE_LOOP: foreach my $node (@nodes) {
702: for (my $child=$node->firstChild; defined $child; $child=$child->nextSibling) {
703: if ($child->nodeType == XML_ELEMENT_NODE) {
704: if (string_in_array($all_block, $child->nodeName) || string_in_array($new_blocks, $child->nodeName)) {
705: push(@change, $tag);
706: last NODE_LOOP;
707: }
708: }
709: }
710: }
711: }
712: foreach my $inline (@change) {
713: my $index = 0;
714: $index++ until $new_inlines->[$index] eq $inline;
715: splice(@{$new_inlines}, $index, 1);
716: push(@{$new_blocks}, $inline);
717: }
718: # add to @containing_styles when a style is used inside
719: # NOTE: some sty elements will be added even though they should not, but if we don't do that
720: # all style will be removed in the sty elements.
721: foreach my $tag ((@{$new_blocks}, @{$new_inlines})) {
722: my @nodes = $root->getElementsByTagName($tag);
723: NODE_LOOP: foreach my $node (@nodes) {
724: for (my $child=$node->firstChild; defined $child; $child=$child->nextSibling) {
725: if ($child->nodeType == XML_ELEMENT_NODE) {
726: if (string_in_array(\@html_styles, $child->nodeName)) {
727: push(@containing_styles, $tag);
728: last NODE_LOOP;
729: }
730: }
731: }
732: }
733: }
734: }
735:
736: # When a style element contains a block, move the style inside the block where it is allowed.
737: # style/block/other -> block/style/other
738: # When a style is used where it is not allowed, move it inside its children or remove it (unless it contains only text)
739: # element_not_containing_styles/style/other -> element_not_containing_styles/other/style (except if other is a style)
740: # The fix is not perfect in the case of element_not_containing_styles/style1/style2/block/text (style1 will be lost):
741: # element_not_containing_styles/style1/style2/block/text -> element_not_containing_styles/block/style2/text
742: # (a solution to this problem would be to merge the styles in a span)
743: # NOTE: .sty defined elements might have been added to @containing_styles by better_guess().
744: sub fix_block_styles {
745: my ($element, $all_block) = @_;
746: my $doc = $element->ownerDocument;
747: if (string_in_array(\@html_styles, $element->nodeName)) {
748: # move spaces out of the style element
749: if (defined $element->firstChild && $element->firstChild->nodeType == XML_TEXT_NODE) {
750: my $child = $element->firstChild;
751: if ($child->nodeValue =~ /^(\s+)(\S.*)$/s) {
752: $element->parentNode->insertBefore($doc->createTextNode($1), $element);
753: $child->setData($2);
754: }
755: }
756: if (defined $element->lastChild && $element->lastChild->nodeType == XML_TEXT_NODE) {
757: my $child = $element->lastChild;
758: if ($child->nodeValue =~ /^(.*\S)(\s+)$/s) {
759: $element->parentNode->insertAfter($doc->createTextNode($2), $element);
760: $child->setData($1);
761: }
762: }
763:
764: my $found_block = 0;
765: for (my $child=$element->firstChild; defined $child; $child=$child->nextSibling) {
766: if ($child->nodeType == XML_ELEMENT_NODE && string_in_array($all_block, $child->nodeName)) {
767: $found_block = 1;
768: last;
769: }
770: }
771: my $no_style_here = !string_in_array(\@containing_styles, $element->parentNode->nodeName);
772: if ($found_block || $no_style_here) {
773: # there is a block or the style is not allowed here,
774: # the style element has to be replaced by its modified children
775: my $s; # a clone of the style
776: my $next;
777: for (my $child=$element->firstChild; defined $child; $child=$next) {
778: $next = $child->nextSibling;
779: if ($child->nodeType == XML_ELEMENT_NODE && (string_in_array($all_block, $child->nodeName) ||
780: $child->nodeName eq 'br' || $no_style_here)) {
781: # avoid inverting a style with a style with $no_style_here (that would cause endless recursion)
782: if (!$no_style_here || (!string_in_array(\@html_styles, $child->nodeName) &&
783: string_in_array(\@containing_styles, $child->nodeName))) {
784: # block node or inline node when the style is not allowed:
785: # move all children inside the style, and make the style the only child
786: $s = $element->cloneNode();
787: my $next2;
788: for (my $child2=$child->firstChild; defined $child2; $child2=$next2) {
789: $next2 = $child2->nextSibling;
790: $child->removeChild($child2);
791: $s->appendChild($child2);
792: }
793: $child->appendChild($s);
794: }
795: $s = undef;
796: } elsif (($child->nodeType == XML_TEXT_NODE && $child->nodeValue !~ /^\s*$/) ||
797: $child->nodeType == XML_ELEMENT_NODE) {
798: # if the style is allowed, move text and inline nodes inside the style
799: if (!$no_style_here) {
800: if (!defined $s) {
801: $s = $element->cloneNode();
802: $element->insertBefore($s, $child);
803: }
804: $element->removeChild($child);
805: $s->appendChild($child);
806: }
807: } else {
808: # do not put other nodes inside the style
809: $s = undef;
810: }
811: }
812: # now replace by children and fix them
813: my $parent = $element->parentNode;
814: for (my $child=$element->firstChild; defined $child; $child=$next) {
815: $next = $child->nextSibling;
816: $element->removeChild($child);
817: $parent->insertBefore($child, $element);
818: if ($child->nodeType == XML_ELEMENT_NODE) {
819: fix_block_styles($child, $all_block);
820: }
821: }
822: $parent->removeChild($element);
823: return;
824: }
825: }
826: # otherwise fix all children
827: my $next;
828: for (my $child=$element->firstChild; defined $child; $child=$next) {
829: $next = $child->nextSibling;
830: if ($child->nodeType == XML_ELEMENT_NODE) {
831: fix_block_styles($child, $all_block);
832: }
833: }
834: }
835:
836: # removes empty font elements and font elements that contain at least one block element
837: # replaces other font elements by equivalent span
838: sub fix_fonts {
839: my ($root, $all_block) = @_;
840: my $doc = $root->ownerDocument;
841: my @fonts = $root->getElementsByTagName('font');
842: @fonts = reverse(@fonts); # to deal with the ancestor last in the case of font/font
843: foreach my $font (@fonts) {
844: my $block = 0;
845: for (my $child=$font->firstChild; defined $child; $child=$child->nextSibling) {
846: if (string_in_array($all_block, $child->nodeName) || string_in_array(\@inline_like_block, $child->nodeName)) {
847: $block = 1;
848: last;
849: }
850: }
851: if (!defined $font->firstChild || $block) {
852: # empty font or font containing block elements
853: # replace this node by its content
854: replace_by_children($font);
855: } else {
856: # replace by equivalent span
857: my $color = get_non_empty_attribute($font, 'color');
858: my $size = get_non_empty_attribute($font, 'size');
859: my $face = get_non_empty_attribute($font, 'face');
860: if (defined $face) {
861: $face =~ s/^,|,$//;
862: }
863: if (!defined $color && !defined $size && !defined $face) {
864: # useless font element: replace this node by its content
865: replace_by_children($font);
866: next;
867: }
868: my $replacement;
869: tie (my %properties, 'Tie::IxHash', ());
870: if (!defined $color && !defined $size && defined $face && lc($face) eq 'symbol') {
871: $replacement = $doc->createDocumentFragment();
872: } else {
873: $replacement = $doc->createElement('span');
874: my $css = '';
875: if (defined $color) {
876: $color =~ s/^x/#/;
877: $properties{'color'} = $color;
878: }
879: if (defined $size) {
880: my %hash = (
881: '1' => 'x-small',
882: '2' => 'small',
883: '3' => 'medium',
884: '4' => 'large',
885: '5' => 'x-large',
886: '6' => 'xx-large',
887: '7' => '300%',
888: '-1' => 'small',
889: '-2' => 'x-small',
890: '+1' => 'large',
891: '+2' => 'x-large',
892: '+3' => 'xx-large',
893: '+4' => '300%',
894: );
895: my $value = $hash{$size};
896: if (!defined $value) {
897: $value = 'medium';
898: }
899: $properties{'font-size'} = $value;
900: }
901: if (defined $face) {
902: if (lc($face) ne 'symbol' && lc($face) ne 'bold') {
903: $properties{'font-family'} = $face;
904: }
905: }
906: set_css_properties($replacement, \%properties);
907: }
908: if (defined $face && lc($face) eq 'symbol') {
909: # convert all content to unicode
910: my $next;
911: for (my $child=$font->firstChild; defined $child; $child=$next) {
912: $next = $child->nextSibling;
913: if ($child->nodeType == XML_TEXT_NODE) {
914: my $value = $child->nodeValue;
915: $value =~ tr/ABGDEZHQIKLMNXOPRSTUFCYWabgdezhqiklmnxoprVstufcywJjv¡«¬®/ΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩαβγδεζηθικλμνξοπρςστυφχψωϑϕϖϒ↔←→/;
916: $child->setData($value);
917: }
918: }
919: }
920: # replace the font node
921: if ($replacement->nodeType == XML_ELEMENT_NODE && !defined $font->previousSibling &&
922: !defined $font->nextSibling && string_in_array(\@accepting_style, $font->parentNode->nodeName)) {
923: # use CSS on the parent block and replace font by its children instead of using a new element
924: set_css_properties($font->parentNode, \%properties);
925: replace_by_children($font);
926: } else {
927: # move all font children inside the replacement (span or fragment)
928: my $next;
929: for (my $child=$font->firstChild; defined $child; $child=$next) {
930: $next = $child->nextSibling;
931: $font->removeChild($child);
932: $replacement->appendChild($child);
933: }
934: # replace font
935: $font->parentNode->replaceChild($replacement, $font);
936: }
937: }
938: }
939: $root->normalize();
940: }
941:
942: # replaces u by <span style="text-decoration: underline">
943: sub replace_u {
944: my ($root) = @_;
945: my $doc = $root->ownerDocument;
946: my @us = $root->getElementsByTagName('u');
947: foreach my $u (@us) {
948: my $span = $doc->createElement('span');
949: $span->setAttribute('style', 'text-decoration: underline');
950: my $next;
951: for (my $child=$u->firstChild; defined $child; $child=$next) {
952: $next = $child->nextSibling;
953: $u->removeChild($child);
954: $span->appendChild($child);
955: }
956: $u->parentNode->replaceChild($span, $u);
957: }
958: }
959:
960: # removes CDATA sections tags that have not been parsed correcty by the HTML parser
961: # also removes bad comments in script elements
962: sub remove_bad_cdata_sections {
963: my ($root) = @_;
964: my $doc = $root->ownerDocument;
965: foreach my $name (@preserve_elements) {
966: my @nodes = $root->getElementsByTagName($name);
967: foreach my $node (@nodes) {
968: if (defined $node->firstChild && $node->firstChild->nodeType == XML_TEXT_NODE) {
969: my $value = $node->firstChild->nodeValue;
970: if ($name eq 'script' && (!defined $node->getAttribute('type') || $node->getAttribute('type') ne 'loncapa/perl') &&
971: !defined $node->firstChild->nextSibling && $value =~ /^(\s*)<!--(.*)-->(\s*)$/) {
972: # web browsers interpret that as a real comment when it is on 1 line, but the Perl HTML parser thinks it is the script
973: # -> turning it back into a comment
974: # (this is only true for Javascript script elements, since LON-CAPA does not parse loncapa/perl scripts in the same way)
975: $node->removeChild($node->firstChild);
976: $node->appendChild($doc->createComment($2));
977: next;
978: }
979: # at the beginning:
980: $value =~ s/^(\s*)<!\[CDATA\[/$1/; # <![CDATA[
981: $value =~ s/^(\s*)\/\*\s*<!\[CDATA\[\s*\*\//$1/; # /* <![CDATA[ */
982: $value =~ s/^(\s*)\/\/\s*<!\[CDATA\[/$1/; # // <![CDATA[
983: $value =~ s/^(\s*)(\/\/)?\s*<!--/$1/; # // <!--
984: # at the end:
985: $value =~ s/\/\/\s*\]\]>(\s*)$/$1/; # // ]]>
986: $value =~ s/\]\]>(\s*)$/$1/; # ]]>
987: $value =~ s/(\/\/)?\s*-->(\s*)$/$2/; # // -->
988: $value =~ s/\/\*\s*\]\]>\s*\*\/(\s*)$/$1/; # /* ]]> */
989:
990: $value = "\n".$value."\n";
991: $value =~ s/\s*(\n[ \t]*)/$1/;
992: $value =~ s/\s+$/\n/;
993: $node->firstChild->setData($value);
994: }
995: }
996: }
997: }
998:
999: # adds CDATA sections to scripts
1000: sub add_cdata_sections {
1001: my ($root) = @_;
1002: my $doc = $root->ownerDocument;
1003: my @scripts = $root->getElementsByTagName('script');
1004: my @answers = $root->getElementsByTagName('answer');
1005: foreach my $answer (@answers) {
1006: my $ancestor = $answer->parentNode;
1007: my $found_capa_response = 0;
1008: while (defined $ancestor) {
1009: if ($ancestor->nodeName eq 'numericalresponse' || $ancestor->nodeName eq 'formularesponse') {
1010: $found_capa_response = 1;
1011: last;
1012: }
1013: $ancestor = $ancestor->parentNode;
1014: }
1015: if (!$found_capa_response) {
1016: push(@scripts, $answer);
1017: }
1018: }
1019: foreach my $script (@scripts) {
1020: # use a CDATA section in the normal situation, for any script
1021: my $first = $script->firstChild;
1022: if (defined $first && $first->nodeType == XML_TEXT_NODE && !defined $first->nextSibling) {
1023: my $cdata = $doc->createCDATASection($first->nodeValue);
1024: $script->replaceChild($cdata, $first);
1025: }
1026: }
1027: }
1028:
1029: # removes "<!--" and "-->" at the beginning and end of style elements
1030: sub fix_style_element {
1031: my ($root) = @_;
1032: my @styles = $root->getElementsByTagName('style');
1033: foreach my $style (@styles) {
1034: if (defined $style->firstChild && $style->firstChild->nodeType == XML_TEXT_NODE &&
1035: !defined $style->firstChild->nextSibling) {
1036: my $text = $style->firstChild->nodeValue;
1037: if ($text =~ /^\s*<!--(.*)-->\s*$/s) {
1038: $style->firstChild->setData($1);
1039: }
1040: }
1041: }
1042: }
1043:
1044: # create missing cells at the end of table rows
1045: sub fix_tables {
1046: my ($root) = @_;
1047: my @tables = $root->getElementsByTagName('table');
1048: foreach my $table (@tables) {
1049: fix_cells($table);
1050: foreach my $tbody ($table->getChildrenByTagName('tbody')) {
1051: fix_cells($tbody);
1052: }
1053: foreach my $thead ($table->getChildrenByTagName('thead')) {
1054: fix_cells($thead);
1055: }
1056: foreach my $tfoot ($table->getChildrenByTagName('tfoot')) {
1057: fix_cells($tfoot);
1058: }
1059: }
1060: }
1061:
1062: # create missing cells at the end of table rows
1063: sub fix_cells {
1064: my ($table) = @_; # could actually be table, tbody, thead or tfoot
1065: my $doc = $table->ownerDocument;
1066: my @nb_cells = ();
1067: my $max_nb_cells = 0;
1068: my @rowspans = ();
1069: my @trs = $table->getChildrenByTagName('tr');
1070: foreach my $tr (@trs) {
1071: my $nb_cells;
1072: if (defined $rowspans[0]) {
1073: $nb_cells = shift(@rowspans);
1074: } else {
1075: $nb_cells = 0;
1076: }
1077: for (my $cell=$tr->firstChild; defined $cell; $cell=$cell->nextSibling) {
1078: if ($cell->nodeName eq 'td' || $cell->nodeName eq 'th') {
1079: my $colspan = $cell->getAttribute('colspan');
1080: if (defined $colspan && $colspan =~ /^\s*[0-9]+\s*$/) {
1081: $nb_cells += $colspan;
1082: } else {
1083: $nb_cells++;
1084: }
1085: my $rowspan = $cell->getAttribute('rowspan');
1086: if (defined $rowspan && $rowspan =~ /^\s*[0-9]+\s*$/) {
1087: for (my $i=0; $i < $rowspan-1; $i++) {
1088: if (!defined $rowspans[$i]) {
1089: $rowspans[$i] = 1;
1090: } else {
1091: $rowspans[$i]++;
1092: }
1093: }
1094: }
1095: }
1096: }
1097: push(@nb_cells, $nb_cells);
1098: if ($nb_cells > $max_nb_cells) {
1099: $max_nb_cells = $nb_cells;
1100: }
1101: }
1102: foreach my $tr (@trs) {
1103: my $nb_cells = shift(@nb_cells);
1104: if ($nb_cells < $max_nb_cells) {
1105: for (1..($max_nb_cells - $nb_cells)) {
1106: $tr->appendChild($doc->createElement('td'));
1107: }
1108: }
1109: }
1110: }
1111:
1112: # replaces ul/ul by ul/li/ul and the same for ol (using the previous li if possible)
1113: # also adds a ul element when a li has no ul/ol ancestor
1114: sub fix_lists {
1115: my ($root) = @_;
1116: my $doc = $root->ownerDocument;
1117: my @uls = $root->getElementsByTagName('ul');
1118: my @ols = $root->getElementsByTagName('ol');
1119: my @lists = (@uls, @ols);
1120: foreach my $list (@lists) {
1121: my $next;
1122: for (my $child=$list->firstChild; defined $child; $child=$next) {
1123: $next = $child->nextSibling;
1124: if ($child->nodeType == XML_ELEMENT_NODE && string_in_array(['ul','ol'], $child->nodeName)) {
1125: my $previous = $child->previousNonBlankSibling(); # note: non-DOM method
1126: $list->removeChild($child);
1127: if (defined $previous && $previous->nodeType == XML_ELEMENT_NODE && $previous->nodeName eq 'li') {
1128: $previous->appendChild($child);
1129: } else {
1130: my $li = $doc->createElement('li');
1131: $li->appendChild($child);
1132: if (!defined $next) {
1133: $list->appendChild($li);
1134: } else {
1135: $list->insertBefore($li, $next);
1136: }
1137: }
1138: }
1139: }
1140: }
1141: my @lis = $root->getElementsByTagName('li');
1142: foreach my $li (@lis) {
1143: my $found_list_ancestor = 0;
1144: my $ancestor = $li->parentNode;
1145: while (defined $ancestor) {
1146: if ($ancestor->nodeName eq 'ul' || $ancestor->nodeName eq 'ol') {
1147: $found_list_ancestor = 1;
1148: last;
1149: }
1150: $ancestor = $ancestor->parentNode;
1151: }
1152: if (!$found_list_ancestor) {
1153: # replace li by ul and add li under ul
1154: my $ul = $doc->createElement('ul');
1155: $li->parentNode->insertBefore($ul, $li);
1156: $li->parentNode->removeChild($li);
1157: $ul->appendChild($li);
1158: # add all other li afterwards inside ul (there might be text nodes in-between)
1159: my $next = $ul->nextSibling;
1160: while (defined $next) {
1161: my $next_next = $next->nextSibling;
1162: if ($next->nodeType == XML_TEXT_NODE && $next->nodeValue =~ /^\s*$/ &&
1163: defined $next_next && $next_next->nodeType == XML_ELEMENT_NODE && $next_next->nodeName eq 'li') {
1164: $next->parentNode->removeChild($next);
1165: $ul->appendChild($next);
1166: $next = $next_next;
1167: $next_next = $next_next->nextSibling;
1168: }
1169: if ($next->nodeType == XML_ELEMENT_NODE && $next->nodeName eq 'li') {
1170: $next->parentNode->removeChild($next);
1171: $ul->appendChild($next);
1172: } else {
1173: last;
1174: }
1175: $next = $next_next;
1176: }
1177: }
1178: }
1179: }
1180:
1181: # Some "image" elements are actually img element with a wrong name. This renames them.
1182: # Amazingly enough, "<image src=..." displays an image in some browsers
1183: # ("image" has existed at some point as an experimental HTML element).
1184: sub fix_wrong_name_for_img {
1185: my ($root) = @_;
1186: my @images = $root->getElementsByTagName('image');
1187: foreach my $image (@images) {
1188: if (!defined $image->getAttribute('src')) {
1189: next;
1190: }
1191: my $found_correct_ancestor = 0;
1192: my $ancestor = $image->parentNode;
1193: while (defined $ancestor) {
1194: if ($ancestor->nodeName eq 'drawimage' || $ancestor->nodeName eq 'imageresponse') {
1195: $found_correct_ancestor = 1;
1196: last;
1197: }
1198: $ancestor = $ancestor->parentNode;
1199: }
1200: if ($found_correct_ancestor) {
1201: next;
1202: }
1203: # this really has to be renamed "img"
1204: $image->setNodeName('img');
1205: }
1206: }
1207:
1208: # Replaces many deprecated attributes and replaces them by equivalent CSS when possible
1209: sub replace_deprecated_attributes_by_css {
1210: my ($root) = @_;
1211:
1212: fix_deprecated_in_tables($root);
1213:
1214: fix_deprecated_in_table_rows($root);
1215:
1216: fix_deprecated_in_table_cells($root);
1217:
1218: fix_deprecated_in_lists($root);
1219:
1220: fix_deprecated_in_list_items($root);
1221:
1222: fix_deprecated_in_hr($root);
1223:
1224: fix_deprecated_in_img($root);
1225:
1226: fix_deprecated_in_body($root);
1227:
1228: fix_align_attribute($root);
1229: }
1230:
1231: # Replaces deprecated attributes in tables
1232: sub fix_deprecated_in_tables {
1233: my ($root) = @_;
1234: my @tables = $root->getElementsByTagName('table');
1235: foreach my $table (@tables) {
1236: tie (my %new_properties, 'Tie::IxHash', ());
1237: my $align = $table->getAttribute('align');
1238: if (defined $align) {
1239: $table->removeAttribute('align');
1240: $align = lc(trim($align));
1241: }
1242: if ($table->parentNode->nodeName eq 'center' || (defined $align && $align eq 'center') ||
1243: (defined $table->parentNode->getAttribute('align') && $table->parentNode->getAttribute('align') eq 'center')) {
1244: $new_properties{'margin-left'} = 'auto';
1245: $new_properties{'margin-right'} = 'auto';
1246: }
1247: if (defined $align && ($align eq 'left' || $align eq 'right')) {
1248: $new_properties{'float'} = $align;
1249: }
1250: my $width = $table->getAttribute('width');
1251: if (defined $width) {
1252: $table->removeAttribute('width');
1253: $width = trim($width);
1254: if ($width =~ /^[0-9]+$/) {
1255: $width .= 'px';
1256: }
1257: if ($width ne '') {
1258: $new_properties{'width'} = $width;
1259: }
1260: }
1261: my $height = $table->getAttribute('height');
1262: if (defined $height) {
1263: $table->removeAttribute('height');
1264: # no replacement for table height
1265: }
1266: my $bgcolor = $table->getAttribute('bgcolor');
1267: if (defined $bgcolor) {
1268: $table->removeAttribute('bgcolor');
1269: $bgcolor = trim($bgcolor);
1270: $bgcolor =~ s/^x\s*//;
1271: if ($bgcolor ne '') {
1272: $new_properties{'background-color'} = $bgcolor;
1273: }
1274: }
1275: my $frame = $table->getAttribute('frame');
1276: if (defined $frame) {
1277: $table->removeAttribute('frame');
1278: $frame = lc(trim($frame));
1279: if ($frame eq 'void') {
1280: $new_properties{'border'} = 'none';
1281: } elsif ($frame eq 'above') {
1282: $new_properties{'border-top'} = '1px solid black';
1283: } elsif ($frame eq 'below') {
1284: $new_properties{'border-bottom'} = '1px solid black';
1285: } elsif ($frame eq 'hsides') {
1286: $new_properties{'border-top'} = '1px solid black';
1287: $new_properties{'border-bottom'} = '1px solid black';
1288: } elsif ($frame eq 'vsides') {
1289: $new_properties{'border-left'} = '1px solid black';
1290: $new_properties{'border-right'} = '1px solid black';
1291: } elsif ($frame eq 'lhs') {
1292: $new_properties{'border-left'} = '1px solid black';
1293: } elsif ($frame eq 'rhs') {
1294: $new_properties{'border-right'} = '1px solid black';
1295: } elsif ($frame eq 'box') {
1296: $new_properties{'border'} = '1px solid black';
1297: } elsif ($frame eq 'border') {
1298: $new_properties{'border'} = '1px solid black';
1299: }
1300: }
1301: if (scalar(keys %new_properties) > 0) {
1302: set_css_properties($table, \%new_properties);
1303: }
1304: # we can't replace the border attribute without creating a style block, but we can improve things like border="BORDER"
1305: my $border = $table->getAttribute('border');
1306: if (defined $border) {
1307: $border = trim($border);
1308: if ($border !~ /^\s*[0-9]+\s*(px)?\s*$/) {
1309: $table->setAttribute('border', '1');
1310: }
1311: }
1312: }
1313:
1314: }
1315:
1316: # Replaces deprecated attributes in tr elements
1317: sub fix_deprecated_in_table_rows {
1318: my ($root) = @_;
1319: my @trs = $root->getElementsByTagName('tr');
1320: foreach my $tr (@trs) {
1321: my $old_properties = get_css_properties($tr);
1322: tie (my %new_properties, 'Tie::IxHash', ());
1323: my $bgcolor = $tr->getAttribute('bgcolor');
1324: if (defined $bgcolor) {
1325: $tr->removeAttribute('bgcolor');
1326: if (!defined $old_properties->{'background-color'}) {
1327: $bgcolor = trim($bgcolor);
1328: $bgcolor =~ s/^x\s*//;
1329: if ($bgcolor ne '') {
1330: $new_properties{'background-color'} = $bgcolor;
1331: }
1332: }
1333: }
1334: my $align = $tr->getAttribute('align');
1335: if (defined $align && $align !~ /\s*char\s*/i) {
1336: $tr->removeAttribute('align');
1337: if (!defined $old_properties->{'text-align'}) {
1338: $align = lc(trim($align));
1339: if ($align ne '') {
1340: $new_properties{'text-align'} = $align;
1341: }
1342: }
1343: }
1344: my $valign = $tr->getAttribute('valign');
1345: if (defined $valign) {
1346: $tr->removeAttribute('valign');
1347: if (!defined $old_properties->{'vertical-align'}) {
1348: $valign = lc(trim($valign));
1349: if ($valign ne '') {
1350: $new_properties{'vertical-align'} = $valign;
1351: }
1352: }
1353: }
1354: if (scalar(keys %new_properties) > 0) {
1355: set_css_properties($tr, \%new_properties);
1356: }
1357: }
1358: }
1359:
1360: # Replaces deprecated attributes in table cells (td and th)
1361: sub fix_deprecated_in_table_cells {
1362: my ($root) = @_;
1363: my @tds = $root->getElementsByTagName('td');
1364: my @ths = $root->getElementsByTagName('th');
1365: my @cells = (@tds, @ths);
1366: foreach my $cell (@cells) {
1367: my $old_properties = get_css_properties($cell);
1368: tie (my %new_properties, 'Tie::IxHash', ());
1369: my $width = $cell->getAttribute('width');
1370: if (defined $width) {
1371: $cell->removeAttribute('width');
1372: if (!defined $old_properties->{'width'}) {
1373: $width = trim($width);
1374: if ($width =~ /^[0-9]+$/) {
1375: $width .= 'px';
1376: }
1377: if ($width ne '') {
1378: $new_properties{'width'} = $width;
1379: }
1380: }
1381: }
1382: my $height = $cell->getAttribute('height');
1383: if (defined $height) {
1384: $cell->removeAttribute('height');
1385: if (!defined $old_properties->{'height'}) {
1386: $height = trim($height);
1387: if ($height =~ /^[0-9]+$/) {
1388: $height .= 'px';
1389: }
1390: if ($height ne '') {
1391: $new_properties{'height'} = $height;
1392: }
1393: }
1394: }
1395: my $bgcolor = $cell->getAttribute('bgcolor');
1396: if (defined $bgcolor) {
1397: $cell->removeAttribute('bgcolor');
1398: if (!defined $old_properties->{'background-color'}) {
1399: $bgcolor = trim($bgcolor);
1400: $bgcolor =~ s/^x\s*//;
1401: if ($bgcolor ne '') {
1402: $new_properties{'background-color'} = $bgcolor;
1403: }
1404: }
1405: }
1406: my $align = $cell->getAttribute('align');
1407: if (defined $align && $align !~ /\s*char\s*/i) {
1408: $cell->removeAttribute('align');
1409: if (!defined $old_properties->{'text-align'}) {
1410: $align = lc(trim($align));
1411: if ($align ne '') {
1412: $new_properties{'text-align'} = $align;
1413: }
1414: }
1415: }
1416: my $valign = $cell->getAttribute('valign');
1417: if (defined $valign) {
1418: $cell->removeAttribute('valign');
1419: if (!defined $old_properties->{'vertical-align'}) {
1420: $valign = lc(trim($valign));
1421: if ($valign ne '') {
1422: $new_properties{'vertical-align'} = $valign;
1423: }
1424: }
1425: }
1426: if (scalar(keys %new_properties) > 0) {
1427: set_css_properties($cell, \%new_properties);
1428: }
1429: }
1430: }
1431:
1432: # Replaces deprecated attributes in lists (ul and ol)
1433: sub fix_deprecated_in_lists {
1434: my ($root) = @_;
1435: my @uls = $root->getElementsByTagName('ul');
1436: my @ols = $root->getElementsByTagName('ol');
1437: my @lists = (@uls, @ols);
1438: foreach my $list (@lists) {
1439: my $type = $list->getAttribute('type');
1440: if (defined $type) {
1441: my $lst = list_style_type($type);
1442: if (defined $lst) {
1443: $list->removeAttribute('type');
1444: if (!defined get_css_property($list, 'list-style-type')) {
1445: set_css_property($list, 'list-style-type', $lst);
1446: }
1447: }
1448: }
1449: }
1450: }
1451:
1452: # Replaces deprecated attributes in list items (li)
1453: sub fix_deprecated_in_list_items {
1454: my ($root) = @_;
1455: my @lis = $root->getElementsByTagName('li');
1456: foreach my $li (@lis) {
1457: my $type = $li->getAttribute('type');
1458: if (defined $type) {
1459: my $lst = list_style_type($type);
1460: if (defined $lst) {
1461: $li->removeAttribute('type');
1462: if (!defined get_css_property($li, 'list-style-type')) {
1463: set_css_property($li, 'list-style-type', $lst);
1464: }
1465: }
1466: }
1467: }
1468: }
1469:
1470: # returns the CSS list-style-type value equivalent to the given type attribute for a list or list item
1471: sub list_style_type {
1472: my ($type) = @_;
1473: my $value;
1474: $type = trim($type);
1475: if (lc($type) eq 'circle') {
1476: $value = 'circle';
1477: } elsif (lc($type) eq 'disc') {
1478: $value = 'disc';
1479: } elsif (lc($type) eq 'square') {
1480: $value = 'square';
1481: } elsif ($type eq 'a') {
1482: $value = 'lower-latin';
1483: } elsif ($type eq 'A') {
1484: $value = 'upper-latin';
1485: } elsif ($type eq 'i') {
1486: $value = 'lower-roman';
1487: } elsif ($type eq 'I') {
1488: $value = 'upper-roman';
1489: } elsif ($type eq '1') {
1490: $value = 'decimal';
1491: }
1492: return $value;
1493: }
1494:
1495: # Replaces deprecated attributes in hr
1496: sub fix_deprecated_in_hr {
1497: my ($root) = @_;
1498: my @hrs = $root->getElementsByTagName('hr');
1499: foreach my $hr (@hrs) {
1500: tie (my %new_properties, 'Tie::IxHash', ());
1501: my $align = $hr->getAttribute('align');
1502: if (defined $align) {
1503: $align = lc(trim($align));
1504: if ($align eq 'left') {
1505: $new_properties{'text-align'} = 'left';
1506: $new_properties{'margin-left'} = '0';
1507: } elsif ($align eq 'right') {
1508: $new_properties{'text-align'} = 'right';
1509: $new_properties{'margin-right'} = '0';
1510: }
1511: $hr->removeAttribute('align');
1512: }
1513: my $color = $hr->getAttribute('color');
1514: if (defined $color) {
1515: $color = trim($color);
1516: $color =~ s/^x\s*//;
1517: if ($color ne '') {
1518: $new_properties{'color'} = $color;
1519: $new_properties{'background-color'} = $color;
1520: }
1521: $hr->removeAttribute('color');
1522: }
1523: my $noshade = $hr->getAttribute('noshade');
1524: my $size = $hr->getAttribute('size');
1525: if (defined $noshade) {
1526: $new_properties{'border-width'} = '0';
1527: if (!defined $color) {
1528: $new_properties{'color'} = 'gray';
1529: $new_properties{'background-color'} = 'gray';
1530: }
1531: if (!defined $size) {
1532: $size = '2';
1533: }
1534: $hr->removeAttribute('noshade');
1535: }
1536: if (defined $size) {
1537: $size = trim($size);
1538: if ($size ne '') {
1539: $new_properties{'height'} = $size.'px';
1540: }
1541: if (defined $hr->getAttribute('size')) {
1542: $hr->removeAttribute('size');
1543: }
1544: }
1545: my $width = $hr->getAttribute('width');
1546: if (defined $width) {
1547: $width = trim($width);
1548: if ($width ne '') {
1549: if ($width !~ /\%$/) {
1550: $width .= 'px';
1551: }
1552: $new_properties{'width'} = $width;
1553: }
1554: $hr->removeAttribute('width');
1555: }
1556: if (scalar(keys %new_properties) > 0) {
1557: set_css_properties($hr, \%new_properties);
1558: }
1559: }
1560: }
1561:
1562: # Replaces deprecated attributes in img
1563: sub fix_deprecated_in_img {
1564: my ($root) = @_;
1565: my @imgs = $root->getElementsByTagName('img');
1566: foreach my $img (@imgs) {
1567: my $old_properties = get_css_properties($img);
1568: tie (my %new_properties, 'Tie::IxHash', ());
1569: my $align = $img->getAttribute('align');
1570: if (defined $align) {
1571: $align = lc(trim($align));
1572: if ($align eq 'middle' || $align eq 'top' || $align eq 'bottom') {
1573: $img->removeAttribute('align');
1574: if (!defined $old_properties->{'vertical-align'}) {
1575: $new_properties{'vertical-align'} = $align;
1576: }
1577: } elsif ($align eq 'left' || $align eq 'right') {
1578: $img->removeAttribute('align');
1579: if (!defined $old_properties->{'float'}) {
1580: $new_properties{'float'} = $align;
1581: }
1582: } elsif ($align eq 'center' || $align eq '') {
1583: $img->removeAttribute('align');
1584: }
1585: }
1586: my $border = $img->getAttribute('border');
1587: if (defined $border) {
1588: $border = lc(trim($border));
1589: if ($border =~ /^[0-9]+\s*(px)?$/) {
1590: $img->removeAttribute('border');
1591: if (!defined $old_properties->{'border'}) {
1592: if ($border !~ /px$/) {
1593: $border .= 'px';
1594: }
1595: $new_properties{'border'} = $border.' solid black';
1596: }
1597: }
1598: }
1599: my $hspace = $img->getAttribute('hspace');
1600: if (defined $hspace) {
1601: $hspace = lc(trim($hspace));
1602: if ($hspace =~ /^[0-9]+\s*(px)?$/) {
1603: $img->removeAttribute('hspace');
1604: if (!defined $old_properties->{'margin-left'} || !defined $old_properties->{'margin-right'}) {
1605: if ($hspace !~ /px$/) {
1606: $hspace .= 'px';
1607: }
1608: $new_properties{'margin-left'} = $hspace;
1609: $new_properties{'margin-right'} = $hspace;
1610: }
1611: }
1612: }
1613: if (scalar(keys %new_properties) > 0) {
1614: set_css_properties($img, \%new_properties);
1615: }
1616: }
1617: }
1618:
1619: # Replaces deprecated attributes in htmlbody (the style attribute could be used in a div for output)
1620: sub fix_deprecated_in_body {
1621: my ($root) = @_;
1622: my $doc = $root->ownerDocument;
1623: my @bodies = $root->getElementsByTagName('htmlbody');
1624: foreach my $body (@bodies) {
1625: my $old_properties = get_css_properties($body);
1626: tie (my %new_properties, 'Tie::IxHash', ());
1627: my $bgcolor = $body->getAttribute('bgcolor');
1628: if (defined $bgcolor) {
1629: $body->removeAttribute('bgcolor');
1630: if (!defined $old_properties->{'background-color'}) {
1631: $bgcolor = trim($bgcolor);
1632: $bgcolor =~ s/^x\s*//;
1633: if ($bgcolor ne '') {
1634: $new_properties{'background-color'} = $bgcolor;
1635: }
1636: }
1637: }
1638: my $color = $body->getAttribute('text');
1639: if (defined $color) {
1640: $body->removeAttribute('text');
1641: if (!defined $old_properties->{'color'}) {
1642: $color = trim($color);
1643: $color =~ s/^x\s*//;
1644: if ($color ne '') {
1645: $new_properties{'color'} = $color;
1646: }
1647: }
1648: }
1649: my $background = $body->getAttribute('background');
1650: if (defined $background && ($background =~ /\.jpe?g$|\.gif|\.png/i)) {
1651: $body->removeAttribute('background');
1652: if (!defined $old_properties->{'background-image'}) {
1653: $background = trim($background);
1654: if ($background ne '') {
1655: $new_properties{'background-image'} = 'url('.$background.')';
1656: }
1657: }
1658: }
1659: # NOTE: these attributes have never been standard and are better removed with no replacement
1660: foreach my $bad ('bottommargin', 'leftmargin', 'rightmargin', 'topmargin', 'marginheight', 'marginwidth') {
1661: if ($body->hasAttribute($bad)) {
1662: $body->removeAttribute($bad);
1663: }
1664: }
1665: # NOTE: link alink and vlink require a <style> block to be converted
1666: my $link = $body->getAttribute('link');
1667: my $alink = $body->getAttribute('alink');
1668: my $vlink = $body->getAttribute('vlink');
1669: if (defined $link || defined $alink || defined $vlink) {
1670: my $head;
1671: my @heads = $root->getElementsByTagName('htmlhead');
1672: if (scalar(@heads) > 0) {
1673: $head = $heads[0];
1674: } else {
1675: $head = $doc->createElement('htmlhead');
1676: $root->insertBefore($head, $root->firstChild);
1677: }
1678: my $style = $doc->createElement('style');
1679: $head->appendChild($style);
1680: my $css = "\n";
1681: if (defined $link) {
1682: $body->removeAttribute('link');
1683: $link = trim($link);
1684: $link =~ s/^x\s*//;
1685: $css .= ' a:link { color:'.$link.' }';
1686: $css .= "\n";
1687: }
1688: if (defined $alink) {
1689: $body->removeAttribute('alink');
1690: $alink = trim($alink);
1691: $alink =~ s/^x\s*//;
1692: $css .= ' a:active { color:'.$alink.' }';
1693: $css .= "\n";
1694: }
1695: if (defined $vlink) {
1696: $body->removeAttribute('vlink');
1697: $vlink = trim($vlink);
1698: $vlink =~ s/^x\s*//;
1699: $css .= ' a:visited { color:'.$vlink.' }';
1700: $css .= "\n";
1701: }
1702: $css .= ' ';
1703: $style->appendChild($doc->createTextNode($css));
1704: }
1705: if (scalar(keys %new_properties) > 0) {
1706: set_css_properties($body, \%new_properties);
1707: } elsif (!$body->hasAttributes) {
1708: $body->parentNode->removeChild($body);
1709: }
1710: }
1711: }
1712:
1713: # replaces <div align="center"> by <div style="text-align:center;">
1714: # also for p and h1..h6
1715: sub fix_align_attribute {
1716: my ($root) = @_;
1717: my @nodes = $root->getElementsByTagName('div');
1718: push(@nodes, $root->getElementsByTagName('p'));
1719: for (my $i=1; $i<=6; $i++) {
1720: push(@nodes, $root->getElementsByTagName('h'.$i));
1721: }
1722: foreach my $node (@nodes) {
1723: my $align = $node->getAttribute('align');
1724: if (defined $align) {
1725: $node->removeAttribute('align');
1726: $align = trim($align);
1727: if ($align ne '' && !defined get_css_property($node, 'text-align')) {
1728: set_css_property($node, 'text-align', lc($align));
1729: }
1730: }
1731: }
1732: }
1733:
1734: # replace center by a div or remove it if there is a table inside
1735: sub replace_center {
1736: my ($root, $all_block) = @_;
1737: my $doc = $root->ownerDocument;
1738: my @centers = $root->getElementsByTagName('center');
1739: foreach my $center (@centers) {
1740: if ($center->getChildrenByTagName('table')->size() > 0) { # note: getChildrenByTagName is not DOM (LibXML specific)
1741: replace_by_children($center);
1742: } else {
1743: if ((!defined $center->previousSibling ||
1744: ($center->previousSibling->nodeType == XML_TEXT_NODE && $center->previousSibling->nodeValue =~ /^\s*$/ && !defined $center->previousSibling->previousSibling)) &&
1745: (!defined $center->nextSibling ||
1746: ($center->nextSibling->nodeType == XML_TEXT_NODE && $center->nextSibling->nodeValue =~ /^\s*$/ && !defined $center->nextSibling->nextSibling)) &&
1747: string_in_array(\@accepting_style, $center->parentNode->nodeName)) {
1748: # use CSS on the parent block and replace center by its children
1749: set_css_property($center->parentNode, 'text-align', 'center');
1750: replace_by_children($center);
1751: } else {
1752: # use p or div ? check if there is a block inside
1753: my $found_block = 0;
1754: for (my $child=$center->firstChild; defined $child; $child=$child->nextSibling) {
1755: if ($child->nodeType == XML_ELEMENT_NODE && string_in_array($all_block, $child->nodeName)) {
1756: $found_block = 1;
1757: last;
1758: }
1759: }
1760: my $new_node;
1761: if ($found_block) {
1762: $new_node = $doc->createElement('div');
1763: $new_node->setAttribute('style', 'text-align: center; margin: 0 auto');
1764: } else {
1765: $new_node = $doc->createElement('p');
1766: $new_node->setAttribute('style', 'text-align: center');
1767: }
1768: my $next;
1769: for (my $child=$center->firstChild; defined $child; $child=$next) {
1770: $next = $child->nextSibling;
1771: $center->removeChild($child);
1772: $new_node->appendChild($child);
1773: }
1774: $center->parentNode->replaceChild($new_node, $center);
1775: }
1776: }
1777: }
1778: }
1779:
1780: # replaces <nobr> by <span style="white-space:nowrap">
1781: sub replace_nobr {
1782: my ($root) = @_;
1783: my @nobrs = $root->getElementsByTagName('nobr');
1784: foreach my $nobr (@nobrs) {
1785: if (!defined $nobr->previousSibling && !defined $nobr->nextSibling &&
1786: string_in_array(\@accepting_style, $nobr->parentNode->nodeName)) {
1787: # use CSS on the parent block
1788: set_css_property($nobr->parentNode, 'white-space', 'nowrap');
1789: replace_by_children($nobr);
1790: } else {
1791: $nobr->setNodeName('span');
1792: $nobr->setAttribute('style', 'white-space:nowrap');
1793: }
1794: }
1795: }
1796:
1797: # removes notsolved tags in the case <hintgroup showoncorrect="no"><notsolved>...</notsolved></hintgroup>
1798: # and in the case <notsolved><hintgroup showoncorrect="no">...</hintgroup></notsolved>
1799: sub remove_useless_notsolved {
1800: my ($root) = @_;
1801: my @hintgroups = $root->getElementsByTagName('hintgroup');
1802: foreach my $hintgroup (@hintgroups) {
1803: my $showoncorrect = get_non_empty_attribute($hintgroup, 'showoncorrect');
1804: if (!defined $showoncorrect || $showoncorrect eq 'no') {
1805: my @notsolveds = $hintgroup->getElementsByTagName('notsolved');
1806: foreach my $notsolved (@notsolveds) {
1807: replace_by_children($notsolved);
1808: }
1809: }
1810: my $parent = $hintgroup->parentNode;
1811: if ($parent->nodeName eq 'notsolved' && scalar(@{$parent->nonBlankChildNodes()}) == 1) {
1812: replace_by_children($parent);
1813: }
1814: }
1815: }
1816:
1817: # Use <pre> for multi-line comments without elements.
1818: sub fix_comments {
1819: my ($root) = @_;
1820: my $doc = $root->ownerDocument;
1821: my @comments = $root->getElementsByTagName('comment');
1822: foreach my $comment (@comments) {
1823: my $first = $comment->firstChild;
1824: if (defined $first) {
1825: if ($first->nodeType == XML_TEXT_NODE && $first->nodeValue =~ /\n/ &&
1826: !defined $first->nextSibling) {
1827: my $pre = $doc->createElement('pre');
1828: $comment->removeChild($first);
1829: $comment->appendChild($pre);
1830: $pre->appendChild($first);
1831: }
1832: }
1833: }
1834: }
1835:
1836: # adds a paragraph inside if needed and calls fix_paragraph for all paragraphs (including new ones)
1837: sub fix_paragraphs_inside {
1838: my ($node, $all_block) = @_;
1839: # blocks in which paragrahs will be added:
1840: my @blocks_with_p = ('loncapa','library','problem','part','problemtype','window','block','while','postanswerdate','preduedate','languageblock','instructorcomment','togglebox','standalone','body','form');
1841: my @fix_p_if_br_or_p = (@responses,'foil','item','text','label','hintgroup','hintpart','hint','web','windowlink','div','li','dd','td','th','blockquote','solved','notsolved');
1842: if ((string_in_array(\@blocks_with_p, $node->nodeName) && paragraph_needed($node)) ||
1843: (string_in_array(\@fix_p_if_br_or_p, $node->nodeName) && paragraph_inside($node))) {
1844: # if non-empty, add paragraphs where needed between all br and remove br
1845: # (it would be easier to just put everything in a p and fix it afterwards, but there are performance issues
1846: # when a paragraph has many blocks directly inside)
1847: my $doc = $node->ownerDocument;
1848: my $p = undef;
1849: my @new_children = ();
1850: my $next;
1851: for (my $child=$node->firstChild; defined $child; $child=$next) {
1852: $next = $child->nextSibling;
1853: $node->removeChild($child);
1854: if ($child->nodeType == XML_ELEMENT_NODE && $child->nodeName eq 'br') {
1855: if (defined $p) {
1856: push(@new_children, $p);
1857: } else {
1858: push(@new_children, $doc->createElement('p'));
1859: }
1860: $p = undef;
1861: # ignore the next node if it is a br (the paragraph default margin will take as much space)
1862: # (ignoring whitespace)
1863: while (defined $next && $next->nodeType == XML_TEXT_NODE && $next->nodeValue =~ /^[ \t\f\n\r]*$/) {
1864: my $next2 = $next->nextSibling;
1865: $node->removeChild($next);
1866: $next = $next2;
1867: }
1868: if (defined $next && $next->nodeType == XML_ELEMENT_NODE && $next->nodeName eq 'br') {
1869: my $next2 = $next->nextSibling;
1870: $node->removeChild($next);
1871: $next = $next2;
1872: }
1873: } elsif ($child->nodeType == XML_ELEMENT_NODE && string_in_array(\@inline_like_block, $child->nodeName)) {
1874: # inline_like_block: use the paragraph if there is one, otherwise do not create one
1875: if (defined $p) {
1876: $p->appendChild($child);
1877: } else {
1878: push(@new_children, $child);
1879: }
1880: } elsif ($child->nodeType == XML_ELEMENT_NODE && string_in_array($all_block, $child->nodeName)) {
1881: # these children are blocks and should not be in a paragraph
1882: if (defined $p) {
1883: push(@new_children, $p);
1884: $p = undef;
1885: }
1886: push(@new_children, $child);
1887: } elsif ($child->nodeType == XML_TEXT_NODE && $child->nodeValue =~ /^[ \t\f\n\r]*$/) {
1888: # blank text: add to paragraph if there is one and there is a next node, otherwise keep out of the paragraph
1889: if (defined $p) {
1890: if (defined $next) {
1891: $p->appendChild($child);
1892: } else {
1893: push(@new_children, $p);
1894: $p = undef;
1895: push(@new_children, $child);
1896: }
1897: } else {
1898: push(@new_children, $child);
1899: }
1900: } elsif ($child->nodeType == XML_TEXT_NODE ||
1901: $child->nodeType == XML_ELEMENT_NODE || $child->nodeType == XML_CDATA_SECTION_NODE ||
1902: $child->nodeType == XML_ENTITY_NODE || $child->nodeType == XML_ENTITY_REF_NODE) {
1903: # these children require a paragraph
1904: if (!defined $p) {
1905: $p = $doc->createElement('p');
1906: }
1907: $p->appendChild($child);
1908: } else {
1909: # these children do not require a paragraph (XML comments, PI)
1910: # -> do not move them in a new paragraph
1911: if (defined $p) {
1912: push(@new_children, $p);
1913: $p = undef;
1914: }
1915: push(@new_children, $child);
1916: }
1917: }
1918: if (defined $p) {
1919: push(@new_children, $p);
1920: }
1921: foreach my $child (@new_children) {
1922: $node->appendChild($child);
1923: }
1924: }
1925: # now fix the paragraphs everywhere, so that all inline nodes are inside a paragraph, and block nodes are outside
1926: my $next;
1927: for (my $child=$node->firstChild; defined $child; $child=$next) {
1928: $next = $child->nextSibling;
1929: if ($child->nodeType == XML_ELEMENT_NODE && defined $child->firstChild) {
1930: if ($child->nodeName eq 'p') {
1931: fix_paragraph($child, $all_block);
1932: } else {
1933: fix_paragraphs_inside($child, $all_block);
1934: }
1935: }
1936: }
1937: }
1938:
1939: # returns 1 if a paragraph is needed inside this node (assuming the parent can have paragraphs)
1940: sub paragraph_needed {
1941: my ($node) = @_;
1942: for (my $child=$node->firstChild; defined $child; $child=$child->nextSibling) {
1943: if (($child->nodeType == XML_TEXT_NODE && $child->nodeValue !~ /^\s*$/) ||
1944: ($child->nodeType == XML_ELEMENT_NODE && !string_in_array(\@inline_like_block, $child->nodeName)) ||
1945: $child->nodeType == XML_CDATA_SECTION_NODE ||
1946: $child->nodeType == XML_ENTITY_NODE || $child->nodeType == XML_ENTITY_REF_NODE) {
1947: return(1);
1948: }
1949: }
1950: return(0);
1951: }
1952:
1953: # returns 1 if there is a paragraph or br in a child of this node, or inside an inline child
1954: sub paragraph_inside {
1955: my ($node) = @_;
1956: # inline elements that can be split in half if there is a paragraph inside (currently all HTML):
1957: # (also used in first_block below)
1958: my @splitable_inline = ('span', 'a', 'strong', 'em' , 'b', 'i', 'sup', 'sub', 'code', 'kbd', 'samp', 'tt', 'ins', 'del', 'var', 'small', 'big', 'font', 'u');
1959: for (my $child=$node->firstChild; defined $child; $child=$child->nextSibling) {
1960: if ($child->nodeType == XML_ELEMENT_NODE) {
1961: my $name = $child->nodeName;
1962: if ($name eq 'p' || $name eq 'br') {
1963: return(1);
1964: } elsif (string_in_array(\@splitable_inline, $name)) {
1965: if (paragraph_inside($child)) {
1966: return(1);
1967: }
1968: }
1969: }
1970: }
1971: return(0);
1972: }
1973:
1974: # fixes paragraphs inside paragraphs (without a block in-between)
1975: sub fix_paragraph {
1976: my ($p, $all_block) = @_;
1977: my $loop_right = 1; # this loops is to avoid out of memory errors with recurse, see below
1978: while ($loop_right) {
1979: $loop_right = 0;
1980: my $block = find_first_block($p, $all_block);
1981: if (defined $block) {
1982: my $trees = clone_ancestor_around_node($p, $block);
1983: my $doc = $p->ownerDocument;
1984: my $replacement = $doc->createDocumentFragment();
1985: my $left = $trees->{'left'};
1986: my $middle = $trees->{'middle'};
1987: my $right = $trees->{'right'};
1988: my $left_needs_p = 0; # 1 if it needs a paragraph (used to replace br later)
1989:
1990: if (defined $left) {
1991: # fix paragraphs inside, in case one of the descendants can have paragraphs inside (like numericalresponse/hintgroup):
1992: for (my $child=$left->firstChild; defined $child; $child=$child->nextSibling) {
1993: if ($child->nodeType == XML_ELEMENT_NODE) {
1994: fix_paragraphs_inside($child, $all_block);
1995: }
1996: }
1997: if (!paragraph_needed($left)) {
1998: # this was just blank text, comments or inline responses, it should not create a new paragraph
1999: my $next;
2000: for (my $child=$left->firstChild; defined $child; $child=$next) {
2001: $next = $child->nextSibling;
2002: $left->removeChild($child);
2003: $replacement->appendChild($child);
2004: }
2005: } else {
2006: $left_needs_p = 1;
2007: $replacement->appendChild($left);
2008: }
2009: }
2010:
2011: my $n = $middle->firstChild;
2012: while (defined $n) {
2013: if ($n->nodeType == XML_ELEMENT_NODE && (string_in_array($all_block, $n->nodeName) || $n->nodeName eq 'br')) {
2014: if ($n->nodeName eq 'p') {
2015: my $parent = $n->parentNode;
2016: # first apply recursion
2017: fix_paragraph($n, $all_block);
2018: # now the p might have been replaced by several nodes, which should replace the initial p
2019: my $next_block;
2020: for (my $block=$parent->firstChild; defined $block; $block=$next_block) {
2021: $next_block = $block->nextSibling;
2022: if ($block->nodeName eq 'p') {
2023: $parent->removeChild($block);
2024: # for each parent before $middle, clone in-between the p and its children (to preserve the styles)
2025: if (defined $block->firstChild) {
2026: for (my $p=$parent; $p!=$middle; $p=$p->parentNode) {
2027: my $newp = $p->cloneNode(0);
2028: my $next;
2029: for (my $child=$block->firstChild; defined $child; $child=$next) {
2030: $next = $child->nextSibling;
2031: $block->removeChild($child);
2032: $newp->appendChild($child);
2033: }
2034: $block->appendChild($newp);
2035: }
2036: }
2037: }
2038: $replacement->appendChild($block);
2039: }
2040: } else {
2041: # replace the whole p by this block, forgetting about intermediate inline elements
2042: $n->parentNode->removeChild($n);
2043: if ($n->nodeName eq 'br') {
2044: # replace a br by a paragraph if there was nothing before in the paragraph,
2045: # otherwise remove it because it already broke the paragraph in half
2046: if (!defined $left || !$left_needs_p) {
2047: $replacement->appendChild($middle);
2048: }
2049: # ignore the next node if it is a br (the paragraph default margin will take as much space)
2050: my $first_right;
2051: if (defined $right) {
2052: $first_right = $right->firstChild;
2053: # ignore non-nbsp whitespace
2054: while (defined $first_right && $first_right->nodeType == XML_TEXT_NODE &&
2055: $first_right->nodeValue =~ /^[ \t\f\n\r]*$/) {
2056: $first_right = $first_right->nextSibling;
2057: }
2058: }
2059: if (defined $first_right && $first_right->nodeType == XML_ELEMENT_NODE &&
2060: $first_right->nodeName eq 'br') {
2061: $right->removeChild($first_right);
2062: }
2063: } else {
2064: fix_paragraphs_inside($n, $all_block);
2065: $replacement->appendChild($n);
2066: }
2067: }
2068: last;
2069: }
2070: $n = $n->firstChild;
2071: if (defined $n && defined $n->nextSibling) {
2072: die "Error in post_xml.fix_paragraph: block not found";
2073: }
2074: }
2075:
2076: if (defined $right) {
2077: if ($block->nodeName eq 'p') {
2078: # remove attributes on the right paragraph
2079: my @attributelist = $right->attributes();
2080: foreach my $att (@attributelist) {
2081: $right->removeAttribute($att->nodeName);
2082: }
2083: }
2084: if ($right->firstChild->nodeType == XML_TEXT_NODE && $right->firstChild->nodeValue =~ /^[ \t\f\n\r]*$/) {
2085: # remove the first text node with whitespace only from the p, it should not trigger the creation of a p
2086: # (but take nbsp into account, so we should not use \s here)
2087: my $first = $right->firstChild;
2088: $right->removeChild($first);
2089: $replacement->appendChild($first);
2090: }
2091: if (defined $right->firstChild) {
2092: if (paragraph_needed($right)) {
2093: $replacement->appendChild($right);
2094: #fix_paragraph($right, $all_block); This is taking way too much memory for blocks with many children
2095: # -> loop instead of recurse
2096: $loop_right = 1;
2097: } else {
2098: # this was just blank text, comments or inline responses, it should not create a new paragraph
2099: my $next;
2100: for (my $child=$right->firstChild; defined $child; $child=$next) {
2101: $next = $child->nextSibling;
2102: $right->removeChild($child);
2103: $replacement->appendChild($child);
2104: # fix paragraphs inside, in case one of the descendants can have paragraphs inside (like numericalresponse/hintgroup):
2105: if ($child->nodeType == XML_ELEMENT_NODE) {
2106: fix_paragraphs_inside($child, $all_block);
2107: }
2108: }
2109: }
2110: }
2111: }
2112:
2113: $p->parentNode->replaceChild($replacement, $p);
2114:
2115: if ($loop_right) {
2116: $p = $right;
2117: }
2118:
2119: } else {
2120: # fix paragraphs inside, in case one of the descendants can have paragraphs inside (like numericalresponse/hintgroup):
2121: my $next;
2122: for (my $child=$p->firstChild; defined $child; $child=$next) {
2123: $next = $child->nextSibling;
2124: if ($child->nodeType == XML_ELEMENT_NODE) {
2125: fix_paragraphs_inside($child, $all_block);
2126: }
2127: }
2128: }
2129: }
2130: }
2131:
2132: sub find_first_block {
2133: my ($node, $all_block) = @_;
2134: # inline elements that can be split in half if there is a paragraph inside (currently all HTML):
2135: my @splitable_inline = ('span', 'a', 'strong', 'em' , 'b', 'i', 'sup', 'sub', 'code', 'kbd', 'samp', 'tt', 'ins', 'del', 'var', 'small', 'big', 'font', 'u');
2136: for (my $child=$node->firstChild; defined $child; $child=$child->nextSibling) {
2137: if ($child->nodeType == XML_ELEMENT_NODE) {
2138: if (string_in_array($all_block, $child->nodeName) || $child->nodeName eq 'br') {
2139: return($child);
2140: }
2141: if (string_in_array(\@splitable_inline, $child->nodeName)) {
2142: my $block = find_first_block($child, $all_block);
2143: if (defined $block) {
2144: return($block);
2145: }
2146: }
2147: }
2148: }
2149: return(undef);
2150: }
2151:
2152: # Creates clones of the ancestor containing the descendants before the node, at the node, and after the node.
2153: # returns a hash with: left, middle, right (left and right can be undef)
2154: sub clone_ancestor_around_node {
2155: my ($ancestor, $node) = @_;
2156: my $middle_node;
2157: my ($left, $middle, $right);
2158: for (my $child=$ancestor->firstChild; defined $child; $child=$child->nextSibling) {
2159: if ($child == $node || is_ancestor_of($child, $node)) {
2160: $middle_node = $child;
2161: last;
2162: }
2163: }
2164: if (!defined $middle_node) {
2165: die "error in split_ancestor_around_node: middle not found";
2166: }
2167: if (defined $middle_node->previousSibling) {
2168: $left = $ancestor->cloneNode(0);
2169: for (my $child=$ancestor->firstChild; $child != $middle_node; $child=$child->nextSibling) {
2170: $left->appendChild($child->cloneNode(1));
2171: }
2172: }
2173: $middle = $ancestor->cloneNode(0);
2174: if ($middle_node == $node) {
2175: $middle->appendChild($middle_node->cloneNode(1));
2176: } else {
2177: my $subres = clone_ancestor_around_node($middle_node, $node);
2178: my $subleft = $subres->{'left'};
2179: if (defined $subleft) {
2180: if (!defined $left) {
2181: $left = $ancestor->cloneNode(0);
2182: }
2183: $left->appendChild($subleft);
2184: }
2185: $middle->appendChild($subres->{'middle'});
2186: my $subright = $subres->{'right'};
2187: if (defined $subright) {
2188: $right = $ancestor->cloneNode(0);
2189: $right->appendChild($subright);
2190: }
2191: }
2192: if (defined $middle_node->nextSibling) {
2193: if (!defined $right) {
2194: $right = $ancestor->cloneNode(0);
2195: }
2196: for (my $child=$middle_node->nextSibling; defined $child; $child=$child->nextSibling) {
2197: $right->appendChild($child->cloneNode(1));
2198: }
2199: }
2200: my %result = ();
2201: $result{'left'} = $left;
2202: $result{'middle'} = $middle;
2203: $result{'right'} = $right;
2204: return(\%result);
2205: }
2206:
2207: sub is_ancestor_of {
2208: my ($n1, $n2) = @_;
2209: my $n = $n2->parentNode;
2210: while (defined $n) {
2211: if ($n == $n1) {
2212: return(1);
2213: }
2214: $n = $n->parentNode;
2215: }
2216: return(0);
2217: }
2218:
2219: # removes empty style elements and replaces the ones with only whitespaces inside by their content
2220: # also remove hints that have become empty after empty style removal.
2221: sub remove_empty_style {
2222: my ($root) = @_;
2223: # actually, preserve some elements like ins when they have whitespace, only remove if they are empty
2224: my @remove_if_empty = ('span', 'strong', 'em' , 'b', 'i', 'sup', 'sub', 'code', 'kbd', 'samp', 'tt', 'ins', 'del', 'var', 'small', 'big', 'font', 'u', 'hint');
2225: my @remove_if_blank = ('span', 'strong', 'em' , 'b', 'i', 'sup', 'sub', 'tt', 'var', 'small', 'big', 'font', 'u', 'hint');
2226: foreach my $name (@remove_if_empty) {
2227: my @nodes = $root->getElementsByTagName($name);
2228: while (scalar(@nodes) > 0) {
2229: my $node = pop(@nodes);
2230: if (!defined $node->firstChild) {
2231: my $parent = $node->parentNode;
2232: if (defined $node->previousSibling && $node->previousSibling->nodeType == XML_TEXT_NODE &&
2233: $node->previousSibling->nodeValue =~ /\$\S*$/) {
2234: # case $a<sup></sup>x
2235: my $value = $node->previousSibling->nodeValue;
2236: $value =~ s/\$(\S*)$/\$\{$1\}/;
2237: $node->previousSibling->setData($value);
2238: }
2239: $parent->removeChild($node);
2240: $parent->normalize();
2241: # now that we removed the node, check if the parent has become an empty style, and so on
2242: while (defined $parent && string_in_array(\@remove_if_empty, $parent->nodeName) && !defined $parent->firstChild) {
2243: my $grandparent = $parent->parentNode;
2244: $grandparent->removeChild($parent);
2245: remove_reference_from_array(\@nodes, $parent);
2246: $parent = $grandparent;
2247: }
2248: }
2249: }
2250: }
2251: foreach my $name (@remove_if_blank) {
2252: my @nodes = $root->getElementsByTagName($name);
2253: while (scalar(@nodes) > 0) {
2254: my $node = pop(@nodes);
2255: if (defined $node->firstChild && !defined $node->firstChild->nextSibling && $node->firstChild->nodeType == XML_TEXT_NODE) {
2256: # NOTE: careful, with UTF-8, \s matches non-breaking spaces and we want to preserve these
2257: if ($node->firstChild->nodeValue =~ /^[\t\n\f\r ]*$/) {
2258: my $parent = $node->parentNode;
2259: replace_by_children($node);
2260: $parent->normalize();
2261: # now that we removed the node, check if the parent has become a style with only whitespace, and so on
2262: while (defined $parent && string_in_array(\@remove_if_blank, $parent->nodeName) &&
2263: (!defined $parent->firstChild ||
2264: (!defined $parent->firstChild->nextSibling && $parent->firstChild->nodeType == XML_TEXT_NODE &&
2265: $parent->firstChild->nodeValue =~ /^^[\t\n\f\r ]*$/))) {
2266: my $grandparent = $parent->parentNode;
2267: replace_by_children($parent);
2268: remove_reference_from_array(\@nodes, $parent);
2269: $parent = $grandparent;
2270: }
2271: }
2272: }
2273: }
2274: }
2275: }
2276:
2277: # remove whitespace inside LON-CAPA elements that have an empty content-model (HTML ones are handled by html_to_xml)
2278: sub fix_empty_lc_elements {
2279: my ($node) = @_;
2280: my @lcempty = ('arc','axis','backgroundplot','drawoptionlist','drawvectorsum','fill','functionplotrule','functionplotvectorrule','functionplotvectorsumrule','hiddenline','hiddensubmission','key','line','location','organicstructure','parameter','plotobject','plotvector','responseparam','spline','textline');
2281: if (string_in_array(\@lcempty, $node->nodeName)) {
2282: if (defined $node->firstChild && !defined $node->firstChild->nextSibling &&
2283: $node->firstChild->nodeType == XML_TEXT_NODE && $node->firstChild->nodeValue =~ /^\s*$/) {
2284: $node->removeChild($node->firstChild);
2285: }
2286: if (defined $node->firstChild) {
2287: if ($warnings) {
2288: print "Warning: a ".$node->nodeName." has something inside\n";
2289: }
2290: }
2291: return;
2292: }
2293: for (my $child=$node->firstChild; defined $child; $child=$child->nextSibling) {
2294: if ($child->nodeType == XML_ELEMENT_NODE) {
2295: fix_empty_lc_elements($child);
2296: }
2297: }
2298: }
2299:
2300: # remove consecutive empty paragraphs (they will not show anyway)
2301: sub reduce_empty_p {
2302: my ($node) = @_;
2303: my $next;
2304: for (my $child=$node->firstChild; defined $child; $child=$next) {
2305: $next = $child->nextSibling;
2306: while (defined $next && $next->nodeType == XML_TEXT_NODE && $next->nodeValue =~ /^[ \t\f\n\r]*$/) {
2307: $next = $next->nextSibling;
2308: }
2309: if ($child->nodeType == XML_ELEMENT_NODE && $child->nodeName eq 'p' && defined $next &&
2310: $next->nodeType == XML_ELEMENT_NODE && $next->nodeName eq 'p') {
2311: my $first = $child->firstChild;
2312: if (!defined $first || (!defined $first->nextSibling &&
2313: $first->nodeType == XML_TEXT_NODE && $first->nodeValue =~ /^[ \t\f\n\r]*$/)) {
2314: $first = $next->firstChild;
2315: if (!defined $first || (!defined $first->nextSibling &&
2316: $first->nodeType == XML_TEXT_NODE && $first->nodeValue =~ /^[ \t\f\n\r]*$/)) {
2317: $node->removeChild($child);
2318: }
2319: }
2320: }
2321: if ($child->nodeType == XML_ELEMENT_NODE) {
2322: reduce_empty_p($child);
2323: }
2324: }
2325: }
2326:
2327: # turn some attribute values into lowercase when they should be
2328: sub lowercase_attribute_values {
2329: my ($root) = @_;
2330: my @with_yesno = (['radiobuttonresponse', ['randomize']],
2331: ['optionresponse', ['randomize']],
2332: ['matchresponse', ['randomize']],
2333: ['itemgroup', ['randomize']],
2334: ['rankresponse', ['randomize']],
2335: ['functionplotresponse', ['xaxisvisible', 'yaxisvisible', 'gridvisible']],
2336: ['backgroundplot', ['fixed']],
2337: ['drawvectorsum', ['showvalue']],
2338: ['textline', ['readonly']],
2339: ['hint', ['showoncorrect']],
2340: ['body', ['dir']],
2341: ['img', ['encrypturl']],
2342: ['form', ['method']],
2343: ['input', ['type']]
2344: );
2345: foreach my $el_attributes (@with_yesno) {
2346: my $el_name = $el_attributes->[0];
2347: my @elements = $root->getElementsByTagName($el_name);
2348: foreach my $element (@elements) {
2349: my $att_list = $el_attributes->[1];
2350: foreach my $att_name (@$att_list) {
2351: my $att_value = $element->getAttribute($att_name);
2352: if (!defined $att_value) {
2353: next;
2354: }
2355: if ($att_value eq 'yes' || $att_value eq 'no') {
2356: next;
2357: }
2358: if ($att_value =~ /\s*yes\s*/i) {
2359: $element->setAttribute($att_name, 'yes');
2360: } elsif ($att_value =~ /\s*no\s*/i) {
2361: $element->setAttribute($att_name, 'no');
2362: }
2363: }
2364: }
2365: }
2366: }
2367:
2368: # fixes spelling mistakes for numericalresponse/@unit
2369: sub replace_numericalresponse_unit_attribute {
2370: my ($root) = @_;
2371: my @numericalresponses = $root->getElementsByTagName('numericalresponse');
2372: foreach my $numericalresponse (@numericalresponses) {
2373: if (defined $numericalresponse->getAttribute('units') && !defined $numericalresponse->getAttribute('unit')) {
2374: $numericalresponse->setAttribute('unit', $numericalresponse->getAttribute('units'));
2375: $numericalresponse->removeAttribute('units');
2376: }
2377: }
2378:
2379: }
2380:
2381: # Replaces &format and &prettyprint by <num> whenever possible.
2382: # Also replaces &chemparse by <chem>.
2383: # If the function call is enclosed in <display>, the <display> element is removed.
2384: sub replace_functions_by_elements {
2385: my ($root) = @_;
2386: my $doc = $root->ownerDocument;
2387: my @preserve = ('script','answer','parse','m','tm','dtm','numericalhintscript'); # display is handled later
2388: my @all = $root->getElementsByTagName('*');
2389: foreach my $element (@all) {
2390: if (string_in_array(\@preserve, $element->nodeName)) {
2391: next;
2392: }
2393: my $changed = 0;
2394: my $next;
2395: for (my $child=$element->firstChild; defined $child; $child=$next) {
2396: $next = $child->nextSibling;
2397: if ($child->nodeType == XML_TEXT_NODE) {
2398: my $value = $child->nodeValue;
2399: if ($value =~ /^(.*)&(?:format|prettyprint)\((\$\{?[a-zA-Z0-9]*\}?(?:\[[^\]]*\])?|[0-9.]+)\s?,\s?(["'][,.\$]?[0-9][eEfFgGsS]["']|\$[a-zA-Z0-9]*)\)(.*)$/s) {
2400: # NOTE: we don't check for &prettyprint's 3rd argument (target), but it has not been seen outside of script elements.
2401: # NOTE: the format options ',' and '$' are not supported by &format in current LON-CAPA since rev 1.81 of default_homework.lcpm,
2402: # but are supported by &prettyprint;
2403: # if we use (like current LON-CAPA) &prettyprint for <num> implementation, it will change a few resulting documents
2404: # (by making them display something they were probably intended to display, but which did not).
2405: # Usage of <num> with &prettyprint instead of &format might also change the display when there is an exponent.
2406: my $before = $1;
2407: my $number = $2;
2408: my $format = $3;
2409: my $after = $4;
2410: $format =~ s/^['"]|['"]$//g;
2411: # do not change this if the parent is <display> and there are other things before or after &format
2412: if ($element->nodeName eq 'display' && (defined $child->previousSibling || defined $next ||
2413: $before !~ /^\s*$/ || $after !~ /^\s*$/)) {
2414: last;
2415: }
2416: my $replacement = $doc->createDocumentFragment();
2417: my $num = $doc->createElement('num');
2418: $num->setAttribute('format', $format);
2419: $num->appendChild($doc->createTextNode($number));
2420: if (length($before) > 0) {
2421: $replacement->appendChild($doc->createTextNode($before));
2422: }
2423: $replacement->appendChild($num);
2424: if (length($after) > 0) {
2425: $replacement->appendChild($doc->createTextNode($after));
2426: }
2427: $element->replaceChild($replacement, $child);
2428: $changed = 1;
2429: $next = $element->firstChild; # start over, there might be another &format in the same text node
2430: } elsif ($value =~ /^(.*)&chemparse\(([^'"()]*|'[^']*'|"[^"]*")\)(.*)$/s) {
2431: my $before = $1;
2432: my $reaction = $2;
2433: my $after = $3;
2434: $reaction =~ s/^'(.*)'$/$1/;
2435: $reaction =~ s/^"(.*)"$/$1/;
2436: if ($element->nodeName eq 'display' && (defined $child->previousSibling || defined $next ||
2437: $before !~ /^\s*$/ || $after !~ /^\s*$/)) {
2438: last;
2439: }
2440: my $replacement = $doc->createDocumentFragment();
2441: my $chem = $doc->createElement('chem');
2442: $chem->appendChild($doc->createTextNode($reaction));
2443: if (length($before) > 0) {
2444: $replacement->appendChild($doc->createTextNode($before));
2445: }
2446: $replacement->appendChild($chem);
2447: if (length($after) > 0) {
2448: $replacement->appendChild($doc->createTextNode($after));
2449: }
2450: $element->replaceChild($replacement, $child);
2451: $changed = 1;
2452: $next = $element->firstChild;
2453: }
2454: }
2455: }
2456: if ($changed && $element->nodeName eq 'display') {
2457: my $first = $element->firstChild;
2458: if ($first->nodeType == XML_ELEMENT_NODE && string_in_array(['num','chem'], $first->nodeName) &&
2459: !defined $first->nextSibling) {
2460: # remove useless display element
2461: replace_by_children($element);
2462: }
2463: }
2464: }
2465: }
2466:
2467: # pretty-print using im-memory DOM tree
2468: sub pretty {
2469: my ($node, $all_block, $indent_level) = @_;
2470: my $doc = $node->ownerDocument;
2471: $indent_level ||= 0;
2472: my $type = $node->nodeType;
2473: if ($type == XML_ELEMENT_NODE) {
2474: my $name = $node->nodeName;
2475: if (string_in_array(\@preserve_elements, $name)) {
2476: # remove newlines at the beginning and the end of preserve elements
2477: if (defined $node->firstChild && ($node->firstChild->nodeType == XML_TEXT_NODE ||
2478: $node->firstChild->nodeType == XML_CDATA_SECTION_NODE)) {
2479: my $text = $node->firstChild->nodeValue;
2480: $text =~ s/^\n+//;
2481: if ($text eq '') {
2482: $node->removeChild($node->firstChild);
2483: } else {
2484: $node->firstChild->setData($text);
2485: }
2486: }
2487: if (defined $node->lastChild && ($node->lastChild->nodeType == XML_TEXT_NODE ||
2488: $node->lastChild->nodeType == XML_CDATA_SECTION_NODE)) {
2489: my $text = $node->lastChild->nodeValue;
2490: $text =~ s/\n+$//;
2491: if ($text eq '') {
2492: $node->removeChild($node->lastChild);
2493: } else {
2494: $node->lastChild->setData($text);
2495: }
2496: }
2497: } elsif (string_in_array($all_block, $name) || string_in_array(\@inline_like_block, $name)) {
2498: # make sure there is a newline at the beginning and at the end if there is anything inside
2499: if (defined $node->firstChild && !string_in_array(\@no_newline_inside, $name)) {
2500: my $first = $node->firstChild;
2501: if ($first->nodeType == XML_TEXT_NODE) {
2502: my $text = $first->nodeValue;
2503: if ($text !~ /^ *\n/) {
2504: $first->setData("\n" . $text);
2505: }
2506: } else {
2507: $node->insertBefore($doc->createTextNode("\n"), $first);
2508: }
2509: my $last = $node->lastChild;
2510: if ($last->nodeType == XML_TEXT_NODE) {
2511: my $text = $last->nodeValue;
2512: if ($text !~ /\n *$/) {
2513: $last->setData($text . "\n");
2514: }
2515: } else {
2516: $node->appendChild($doc->createTextNode("\n"));
2517: }
2518: }
2519:
2520: # indent and make sure there is a newline before and after a block element
2521: my $newline_indent = "\n".(' ' x (2*($indent_level + 1)));
2522: my $newline_indent_last = "\n".(' ' x (2*$indent_level));
2523: my $next;
2524: for (my $child=$node->firstChild; defined $child; $child=$next) {
2525: $next = $child->nextSibling;
2526: if ($child->nodeType == XML_ELEMENT_NODE) {
2527: if (string_in_array($all_block, $child->nodeName) || string_in_array(\@inline_like_block, $child->nodeName)) {
2528: # make sure there is a newline before and after a block element
2529: if (defined $child->previousSibling && $child->previousSibling->nodeType == XML_TEXT_NODE) {
2530: my $prev = $child->previousSibling;
2531: my $text = $prev->nodeValue;
2532: if ($text !~ /\n *$/) {
2533: $prev->setData($text . $newline_indent);
2534: }
2535: } else {
2536: $node->insertBefore($doc->createTextNode($newline_indent), $child);
2537: }
2538: if (defined $next && $next->nodeType == XML_TEXT_NODE) {
2539: my $text = $next->nodeValue;
2540: if ($text !~ /^ *\n/) {
2541: $next->setData($newline_indent . $text);
2542: }
2543: } else {
2544: $node->insertAfter($doc->createTextNode($newline_indent), $child);
2545: }
2546: }
2547: pretty($child, $all_block, $indent_level+1);
2548: } elsif ($child->nodeType == XML_TEXT_NODE) {
2549: my $text = $child->nodeValue;
2550: # collapse newlines
2551: $text =~ s/\n([\t ]*\n)+/\n/g;
2552: # indent and remove spaces and tabs before newlines
2553: if (defined $next) {
2554: $text =~ s/[\t ]*\n[\t ]*/$newline_indent/ge;
2555: } else {
2556: $text =~ s/[\t ]*\n[\t ]*/$newline_indent/ge;
2557: $text =~ s/[\t ]*\n[\t ]*$/$newline_indent_last/e;
2558: }
2559: $child->setData($text);
2560: }
2561: }
2562:
2563: # removes whitespace at the beginning and end of p td, th and li (except for nbsp at the beginning)
2564: my @to_trim = ('p','td','th','li');
2565: if (string_in_array(\@to_trim, $name) && defined $node->firstChild && $node->firstChild->nodeType == XML_TEXT_NODE) {
2566: my $text = $node->firstChild->nodeValue;
2567: $text =~ s/^[ \t\f\n\r]*//;
2568: if ($text eq '') {
2569: $node->removeChild($node->firstChild);
2570: } else {
2571: $node->firstChild->setData($text);
2572: }
2573: }
2574: if (string_in_array(\@to_trim, $name) && defined $node->lastChild && $node->lastChild->nodeType == XML_TEXT_NODE) {
2575: my $text = $node->lastChild->nodeValue;
2576: $text =~ s/\s*$//;
2577: if ($text eq '') {
2578: $node->removeChild($node->lastChild);
2579: } else {
2580: $node->lastChild->setData($text);
2581: }
2582: }
2583: }
2584: }
2585: }
2586:
2587: sub replace_tm_dtm {
2588: my ($root) = @_;
2589: my $doc = $root->ownerDocument;
2590: my @elements = $root->getElementsByTagName('tm');
2591: push(@elements, $root->getElementsByTagName('dtm'));
2592: foreach my $element (@elements) {
2593: my $first = $element->firstChild;
2594: if (defined $first && $first->nodeType == XML_TEXT_NODE) {
2595: my $text = $first->nodeValue;
2596: if ($element->nodeName eq 'tm') {
2597: $first->setData('$'.$text.'$');
2598: } else {
2599: $first->setData('$$'.$text.'$$');
2600: }
2601: }
2602: $element->setNodeName('m');
2603: }
2604: }
2605:
2606:
2607: ######## utilities ########
2608:
2609: ##
2610: # Trims a string (really, this should be built-in in Perl, this is ridiculous, ugly and slow)
2611: # @param {string} s - the string to trim
2612: # @returns the trimmed string
2613: ##
2614: sub trim {
2615: my ($s) = @_;
2616: $s =~ s/^\s+//;
2617: $s =~ s/\s+$//;
2618: return($s);
2619: }
2620:
2621: ##
2622: # Tests if a string is in an array (using eq) (to avoid Smartmatch warnings with $value ~~ @array)
2623: # @param {Array<string>} array - reference to the array of strings
2624: # @param {string} value - the string to look for
2625: # @returns 1 if found, 0 otherwise
2626: ##
2627: sub string_in_array {
2628: my ($array, $value) = @_;
2629: # NOTE: would it be faster to use "any { $value eq $_ } @{$array}" from List::Util ?
2630: foreach my $v (@{$array}) {
2631: if ($v eq $value) {
2632: return 1;
2633: }
2634: }
2635: return 0;
2636: }
2637:
2638: ##
2639: # Tests if an object is in an array (using ==)
2640: # @param {Array<Object>} array - reference to the array of references
2641: # @param {Object} ref - the reference to look for
2642: # @returns 1 if found, 0 otherwise
2643: ##
2644: sub reference_in_array {
2645: my ($array, $ref) = @_;
2646: foreach my $v (@{$array}) {
2647: if ($v == $ref) {
2648: return 1;
2649: }
2650: }
2651: return 0;
2652: }
2653:
2654: ##
2655: # returns the index of a string in an array
2656: # @param {Array<Object>} array - reference to the array of strings
2657: # @param {string} s - the string to look for (using eq)
2658: # @returns the index if found, -1 otherwise
2659: ##
2660: sub index_of_string {
2661: my ($array, $s) = @_;
2662: for (my $i=0; $i<scalar(@{$array}); $i++) {
2663: if ($array->[$i] eq $s) {
2664: return $i;
2665: }
2666: }
2667: return -1;
2668: }
2669:
2670: ##
2671: # returns the index of a reference in an array
2672: # @param {Array<Object>} array - reference to the array of references
2673: # @param {Object} ref - the reference to look for
2674: # @returns the index if found, -1 otherwise
2675: ##
2676: sub index_of_reference {
2677: my ($array, $ref) = @_;
2678: for (my $i=0; $i<scalar(@{$array}); $i++) {
2679: if ($array->[$i] == $ref) {
2680: return $i;
2681: }
2682: }
2683: return -1;
2684: }
2685:
2686: ##
2687: # if found, removes a string from an array, otherwise do nothing
2688: # @param {Array<string>} array - reference to the array of string
2689: # @param {string} s - the string to look for (using eq)
2690: ##
2691: sub remove_string_from_array {
2692: my ($array, $s) = @_;
2693: my $index = index_of_string($array, $s);
2694: if ($index != -1) {
2695: splice(@$array, $index, 1);
2696: }
2697: }
2698:
2699: ##
2700: # if found, removes a reference from an array, otherwise do nothing
2701: # @param {Array<Object>} array - reference to the array of references
2702: # @param {Object} ref - the reference to look for
2703: ##
2704: sub remove_reference_from_array {
2705: my ($array, $ref) = @_;
2706: my $index = index_of_reference($array, $ref);
2707: if ($index != -1) {
2708: splice(@$array, $index, 1);
2709: }
2710: }
2711:
2712: ##
2713: # replaces a node by its children
2714: # @param {Node} node - the DOM node
2715: ##
2716: sub replace_by_children {
2717: my ($node) = @_;
2718: my $parent = $node->parentNode;
2719: my $next;
2720: my $previous;
2721: for (my $child=$node->firstChild; defined $child; $child=$next) {
2722: $next = $child->nextSibling;
2723: if ((!defined $previous || !defined $next) &&
2724: $child->nodeType == XML_TEXT_NODE && $child->nodeValue =~ /^\s*$/) {
2725: next; # do not keep first and last whitespace nodes
2726: } else {
2727: if (!defined $previous && $child->nodeType == XML_TEXT_NODE) {
2728: # remove whitespace at the beginning
2729: my $value = $child->nodeValue;
2730: $value =~ s/^\s+//;
2731: $child->setData($value);
2732: }
2733: if (!defined $next && $child->nodeType == XML_TEXT_NODE) {
2734: # and at the end
2735: my $value = $child->nodeValue;
2736: $value =~ s/\s+$//;
2737: $child->setData($value);
2738: }
2739: }
2740: $node->removeChild($child);
2741: $parent->insertBefore($child, $node);
2742: $previous = $child;
2743: }
2744: $parent->removeChild($node);
2745: }
2746:
2747: ##
2748: # returns the trimmed attribute value if the attribute exists and is not blank, undef otherwise
2749: # @param {Node} node - the DOM node
2750: # @param {string} attribute_name - the attribute name
2751: ##
2752: sub get_non_empty_attribute {
2753: my ($node, $attribute_name) = @_;
2754: my $value = $node->getAttribute($attribute_name);
2755: if (defined $value && $value !~ /^\s*$/) {
2756: $value = trim($value);
2757: return($value);
2758: }
2759: return(undef);
2760: }
2761:
2762: ##
2763: # Returns a CSS property value from the style attribute of the element, or undef if not defined
2764: # @param {Element} el - the DOM element
2765: # @param {string} property_name - the CSS property name
2766: ##
2767: sub get_css_property {
2768: my ($el, $property_name) = @_;
2769: my $style = $el->getAttribute('style');
2770: if (defined $style) {
2771: $style =~ s/^\s*;\s*//;
2772: $style =~ s/\s*;\s*$//;
2773: } else {
2774: $style = '';
2775: }
2776: my @pairs = split(';', $style);
2777: foreach my $pair (@pairs) {
2778: my @name_value = split(':', $pair);
2779: if (scalar(@name_value) != 2) {
2780: next;
2781: }
2782: my $name = trim($name_value[0]);
2783: my $value = trim($name_value[1]);
2784: if (lc($name) eq $property_name) {
2785: return($value); # return the first one found
2786: }
2787: }
2788: return(undef);
2789: }
2790:
2791: ##
2792: # Returns the reference to a hash CSS property name => value from the style attribute of the element.
2793: # Returns an empty list if the style attribute is not defined,
2794: # @param {Element} el - the DOM element
2795: # @return {Hash<string, string>} reference to the hash property name => property value
2796: ##
2797: sub get_css_properties {
2798: my ($el) = @_;
2799: my $style = $el->getAttribute('style');
2800: if (defined $style) {
2801: $style =~ s/^\s*;\s*//;
2802: $style =~ s/\s*;\s*$//;
2803: } else {
2804: $style = '';
2805: }
2806: my @pairs = split(';', $style);
2807: tie (my %hash, 'Tie::IxHash', ());
2808: foreach my $pair (@pairs) {
2809: my @name_value = split(':', $pair);
2810: if (scalar(@name_value) != 2) {
2811: next;
2812: }
2813: my $name = trim($name_value[0]);
2814: my $value = trim($name_value[1]);
2815: if (defined $hash{$name}) {
2816: # duplicate property in the style attribute: keep only the last one
2817: delete $hash{$name};
2818: }
2819: $hash{$name} = $value;
2820: }
2821: return(\%hash);
2822: }
2823:
2824: ##
2825: # Sets a CSS property in the style attribute of an element
2826: # @param {Element} el - the DOM element
2827: # @param {string} property_name - the CSS property name
2828: # @param {string} property_value - the CSS property value
2829: ##
2830: sub set_css_property {
2831: my ($el, $property_name, $property_value) = @_;
2832: my $hash_ref = { $property_name => $property_value };
2833: set_css_properties($el, $hash_ref);
2834: }
2835:
2836: ##
2837: # Sets several CSS properties in the style attribute of an element
2838: # @param {Element} el - the DOM element
2839: # @param {Hash<string, string>} properties - reference to the hash property name => property value
2840: ##
2841: sub set_css_properties {
2842: my ($el, $properties) = @_;
2843: my $hash = get_css_properties($el);
2844: foreach my $property_name (keys %$properties) {
2845: my $property_value = $properties->{$property_name};
2846: if (defined $hash->{$property_name}) {
2847: delete $hash->{$property_name}; # to add the new one at the end
2848: }
2849: $hash->{$property_name} = $property_value;
2850: }
2851: my $style = '';
2852: foreach my $key (keys %$hash) {
2853: $style .= $key.':'.$hash->{$key}.'; ';
2854: }
2855: $style =~ s/; $//;
2856: $el->setAttribute('style', $style);
2857: }
2858:
2859: 1;
2860: __END__
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to post_xml.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / homework / cleanxml