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