1: #!/usr/bin/perl
2:
3: package pre_xml;
4:
5: use strict;
6: use utf8;
7:
8: use Encode;
9: use Encode::Byte;
10: use Encode::Guess;
11:
12: # list of elements inside which < and > might not be turned into entities
13: # unfortunately, answer can sometimes contain the elements vector and value...
14: my @cdata_elements = ('answer', 'm', 'display', 'parse'); # not script because the HTML parser will handle it
15:
16:
17: # Reads a LON-CAPA 2 file, guesses the encoding, fixes characters in cdata_elements, fixes HTML entities,
18: # and returns the converted text.
19: sub pre_xml {
20: my ($filepath) = @_;
21:
22: my $lines = guess_encoding_and_read($filepath);
23:
24: remove_control_characters($lines);
25:
26: fix_cdata_elements($lines);
27:
28: fix_html_entities($lines);
29:
30: fix_missing_quotes($lines);
31:
32: fix_empty_li($lines);
33:
34: remove_doctype($lines);
35:
36: add_root($lines, $filepath);
37:
38: return(\join('', @$lines));
39: }
40:
41:
42: ##
43: # Tries to guess the character encoding, and returns the lines as decoded text.
44: # Requires Encode::Byte.
45: ##
46: sub guess_encoding_and_read {
47: my ($fn) = @_;
48: no warnings "utf8";
49: local $/ = undef;
50: open(my $fh, "<", $fn) or die "cannot read $fn: $!";
51: binmode $fh;
52: my $data = <$fh>; # we need to read the whole file to test if font is a block or inline element
53: close $fh;
54:
55: if (index($data, '<') == -1) {
56: die "This file has no markup !";
57: }
58:
59: # try to get a charset from a meta at the beginning of the file
60: my $beginning = substr($data, 0, 1024); # to avoid a full match; hopefully we won't cut the charset in half
61: if ($beginning =~ /<meta[^>]*charset\s?=\s?([^\n>"';]*)/i) {
62: my $meta_charset = $1;
63: if ($meta_charset ne '') {
64: if ($meta_charset =~ /iso-?8859-?1/i) {
65: # usually a lie
66: $meta_charset = 'cp1252';
67: }
68: # now try to decode using that encoding
69: my $decoder = guess_encoding($data, ($meta_charset));
70: if (ref($decoder)) {
71: my $decoded = $decoder->decode($data);
72: my @lines = split(/^/m, $decoded);
73: return \@lines;
74: } else {
75: print "Warning: decoding did not work with the charset defined by the meta ($meta_charset)\n";
76: }
77: }
78: }
79:
80: my $decoded;
81: if (length($data) > 0) {
82: # NOTE: this list is too ambigous, Encode::Guess refuses to even try a guess
83: #Encode::Guess->set_suspects(qw/ascii UTF-8 iso-8859-1 MacRoman cp1252/);
84: # by default Encode::Guess uses ascii, utf8 and UTF-16/32 with BOM
85: my $decoder = Encode::Guess->guess($data);
86: if (ref($decoder)) {
87: $decoded = $decoder->decode($data);
88: # NOTE: this seems to accept binary files sometimes (conversion will fail later because it is not really UTF-8)
89: } else {
90: print "Warning: encoding is not UTF-8 for $fn";
91:
92: # let's try iso-2022-jp first
93: $decoder = Encode::Guess->guess($data, 'iso-2022-jp');
94: if (ref($decoder)) {
95: $decoded = $decoder->decode($data);
96: print "; using iso-2022-jp\n";
97: } else {
98: # NOTE: cp1252 is identical to iso-8859-1 but with additionnal characters in range 128-159
99: # instead of control codes. We can assume that these control codes are not used, so there
100: # is no need to test for iso-8859-1.
101: # The main problem here is to distinguish between cp1252 and MacRoman.
102: # see http://www.alanwood.net/demos/charsetdiffs.html#f
103: my $decoded_windows = decode('cp1252', $data);
104: my $decoded_mac = decode('MacRoman', $data);
105: # try to use frequent non-ASCII characters to distinguish the encodings (languages: mostly German, Spanish, Portuguese)
106: # í has been removed because it conflicts with ’ and ’ is more frequent
107: # ± has been removed because it is, suprisingly, the same code in both encodings !
108: my $score_windows = $decoded_windows =~ tr/ßáàäâãçéèêëñóöôõúüÄÉÑÖÜ¿¡‘’“” °½–—…§//;
109: my $score_mac = $decoded_mac =~ tr/ßáàäâãçéèêëñóöôõúüÄÉÑÖÜ¿¡‘’“” °½–—…§//;
110: # check newlines too (\r on MacOS < X, \r\n on Windows)
111: my $ind_cr = index($data, "\r");
112: if ($ind_cr != -1) {
113: if (substr($data, $ind_cr + 1, 1) eq "\n") {
114: $score_windows++;
115: } else {
116: $score_mac++;
117: }
118: }
119: if ($score_windows >= $score_mac) {
120: $decoded = $decoded_windows;
121: print "; guess=cp1252 ($score_windows cp1252 >= $score_mac MacRoman)\n";
122: } else {
123: print "; guess=MacRoman ($score_mac MacRoman > $score_windows cp1252)\n";
124: $decoded = $decoded_mac;
125: }
126: }
127: }
128: } else {
129: $decoded = '';
130: }
131: my @lines = split(/^/m, $decoded);
132: return \@lines;
133: }
134:
135:
136: ##
137: # Removes some control characters
138: # @param {Array<string>} lines
139: ##
140: sub remove_control_characters {
141: my ($lines) = @_;
142: foreach my $line (@{$lines}) {
143: $line =~ s/[\x00-\x07\x0B\x0C\x0E-\x1F]//g;
144: $line =~ s/&#[0-7];//g;
145: $line =~ s/[4-9];//g;
146: $line =~ s/[0-9];//g;
147: }
148: }
149:
150: ##
151: # Replaces < and > characters by < and > in cdata elements (listed in @cdata_elements).
152: # EXCEPT for answer when it's inside numericalresponse or formularesponse.
153: # @param {Array<string>} lines
154: ##
155: sub fix_cdata_elements {
156: my ($lines) = @_;
157: my $i = 0;
158: my $j = 0;
159: my $tag = '';
160: my $type;
161: my $in_numericalresponse = 0;
162: my $in_formularesponse = 0;
163: my $in_script = 0;
164: ($tag, $type, $i, $j) = next_tag($lines, $i, $j);
165: while ($tag ne '') {
166: if ($tag eq 'numericalresponse') {
167: if ($type eq 'start') {
168: $in_numericalresponse = 1;
169: } else {
170: $in_numericalresponse = 0;
171: }
172: } elsif ($tag eq 'formularesponse') {
173: if ($type eq 'start') {
174: $in_formularesponse = 1;
175: } else {
176: $in_formularesponse = 0;
177: }
178: } elsif ($tag eq 'script') {
179: if ($type eq 'start') {
180: $in_script = 1;
181: } else {
182: $in_script = 0;
183: }
184: }
185: if ($type eq 'start' && in_array_ignore_case(\@cdata_elements, $tag) && !$in_script &&
186: ($tag ne 'answer' || (!$in_numericalresponse && !$in_formularesponse))) {
187: my $cde = $tag;
188: my $line = $lines->[$i];
189: $j = index($line, '>', $j+1) + 1;
190: my $stop = 0;
191: while (!$stop && $i < scalar(@{$lines})) {
192: my $indinf = index($line, '<', $j);
193: if ($indinf != -1 && index($line, '<![CDATA[', $indinf) == $indinf) {
194: $i++;
195: $line = $lines->[$i];
196: $j = 0;
197: last;
198: }
199: my $indsup = index($line, '>', $j);
200: if ($indinf != -1 && $indsup != -1 && $indinf < $indsup) {
201: my $test = substr($line, $indinf + 1, $indsup - ($indinf + 1));
202: $test =~ s/^\s+|\s+$//g ;
203: if ($test eq '/'.$cde) {
204: $stop = 1;
205: $j = $indsup;
206: # this is commented because of markup like <display>&web(' ','','<p>')</display>
207: #} elsif ($test =~ /^[a-zA-Z\/]$/) {
208: # $j = $indsup + 1;
209: } else {
210: $line = substr($line, 0, $indinf).'<'.substr($line, $indinf+1);
211: $lines->[$i] = $line;
212: }
213: } elsif ($indinf != -1 && $indsup == -1) {
214: $line = substr($line, 0, $indinf).'<'.substr($line, $indinf+1);
215: $lines->[$i] = $line;
216: } elsif ($indsup != -1 && ($indinf == -1 || $indsup < $indinf)) {
217: $line = substr($line, 0, $indsup).'>'.substr($line, $indsup+1);
218: $lines->[$i] = $line;
219: } else {
220: $i++;
221: $line = $lines->[$i];
222: $j = 0;
223: }
224: }
225: }
226: $j++;
227: ($tag, $type, $i, $j) = next_tag($lines, $i, $j);
228: }
229: }
230:
231:
232: ##
233: # Replaces HTML entities (they are not XML unless a DTD is used, which is no longer recommanded for XHTML).
234: # @param {Array<string>} lines
235: ##
236: sub fix_html_entities {
237: my ($lines) = @_;
238: foreach my $line (@{$lines}) {
239: # html_to_xml is converting named entities before 255 (see HTML parser dtext)
240: # Assuming Windows encoding (Unicode entities are not before 160 and are the same between 160 and 255):
241: $line =~ s/€|€/€/g;
242: $line =~ s/‚|‚/‚/g;
243: $line =~ s/„|„/„/g;
244: $line =~ s/…|…/…/g;
245: $line =~ s/†|†/†/g;
246: $line =~ s/‡|‡/‡/g;
247: $line =~ s/ˆ|ˆ/ˆ/g;
248: $line =~ s/‰|‰/‰/g;
249: $line =~ s/‹|‹/‹/g;
250: $line =~ s/‘|‘/‘/g;
251: $line =~ s/’|’/’/g;
252: $line =~ s/“|“/“/g;
253: $line =~ s/”|”/”/g;
254: $line =~ s/•|•/•/g;
255: $line =~ s/–|–/–/g;
256: $line =~ s/—|—/—/g;
257: $line =~ s/˜|˜/˜/g;
258: $line =~ s/™|™/™/g;
259: $line =~ s/›|›/›/g;
260: $line =~ s/œ|œ/œ/g;
261: }
262: }
263:
264:
265: # Tries to fix things like <font color="#990000" face="Verdana,>
266: # without breaking <a b="c>d">
267: # This is only fixing tags when there is a single tag in a line (it is impossible to fix in the general case).
268: # Also transforms <a b="c> <d e=" into <a b="c"><d e=" ,
269: # and (no markup before)<a b="c> (no quote after) into <a b="c"> .
270: sub fix_missing_quotes {
271: my ($lines) = @_;
272: foreach my $line (@{$lines}) {
273: my $n_inf = $line =~ tr/<//;
274: my $n_sup = $line =~ tr/>//;
275: if ($n_inf == 1 && $n_sup == 1) {
276: my $ind_inf = index($line, '<');
277: my $ind_sup = index($line, '>');
278: if ($ind_inf != -1 && $ind_sup != -1 && $ind_inf < $ind_sup) {
279: my $n_quotes = substr($line, $ind_inf, $ind_sup) =~ tr/"//;
280: if ($n_quotes % 2 != 0) {
281: # add a quote before > when there is an odd number of quotes inside <>
282: $line =~ s/>/">/;
283: }
284: }
285: }
286: $line =~ s/(<[a-zA-Z]+ [a-zA-Z]+="[^"<>\s]+)(>\s*<[a-zA-Z]+ [a-zA-Z]+=")/$1"$2/;
287: $line =~ s/^([^"<>]*<[a-zA-Z]+ [a-zA-Z]+="[^"<>\s]+)(>[^"]*)$/$1"$2/;
288: }
289: }
290:
291:
292: # Replaces <li/> by <li> (the end tag will be added in html_to_xml
293: sub fix_empty_li {
294: my ($lines) = @_;
295: foreach my $line (@{$lines}) {
296: $line =~ s/<li\s?\/>/<li>/;
297: }
298: }
299:
300:
301: # remove doctypes, without assuming they are at the beginning
302: sub remove_doctype {
303: my ($lines) = @_;
304: foreach my $line (@{$lines}) {
305: $line =~ s/<!DOCTYPE[^>]*>//;
306: }
307: }
308:
309:
310: # Adds a problem, library or html root element, enclosing things outside of the problem element.
311: # (any extra root element will be removed in post_xml, but this ensures one is added as root if missing).
312: sub add_root {
313: my ($lines, $filepath) = @_;
314: my $root_name;
315: if ($filepath =~ /\.library$/i) {
316: $root_name = 'library';
317: } elsif ($filepath =~ /\.html?$/i) {
318: $root_name = 'html';
319: } else {
320: $root_name = 'problem';
321: }
322: if ($root_name eq 'library') {
323: foreach my $line (@{$lines}) {
324: if ($line =~ /^\s*<[a-z]/) {
325: last;
326: }
327: if ($line !~ /^\s*$/) {
328: die "this library does not start with a tag, it might be a scriptlib";
329: }
330: }
331: }
332: my $line1 = $lines->[0];
333: $line1 =~ s/<\?.*\?>//; # remove any PI, it would cause problems later anyway
334: $line1 = "<$root_name>".$line1;
335: $lines->[0] = $line1;
336: $lines->[scalar(@$lines)-1] = $lines->[scalar(@$lines)-1]."</$root_name>";
337: }
338:
339:
340: ##
341: # Returns information about the next tag, starting at line number and char number.
342: # Assumes the markup is well-formed and there is no CDATA,
343: # which is not always true (like inside script), so results might be wrong sometimes.
344: # It is however useful to avoid unnecessary changes in the document (using a parser to
345: # do read/write for the whole document would mess up non well-formed documents).
346: # @param {Array<string>} lines
347: # @param {int} line_number - line number to start at
348: # @param {int} char_number - char number to start at on the line
349: # @returns (tag, type, line_number, char_number)
350: ##
351: sub next_tag {
352: my ($lines, $i, $j ) = @_;
353: my $i2 = $i;
354: my $j2 = $j;
355: while ($i2 < scalar(@{$lines})) {
356: my $line = $lines->[$i2];
357: $j2 = index($line, '<', $j2);
358: #TODO: handle comments
359: while ($j2 != -1) {
360: my $ind_slash = index($line, '/', $j2);
361: my $ind_sup = index($line, '>', $j2);
362: my $ind_space = index($line, ' ', $j2);
363: my $type;
364: my $tag;
365: if ($ind_slash == $j2 + 1 && $ind_sup != -1) {
366: $type = 'end';
367: $tag = substr($line, $j2 + 2, $ind_sup - ($j2 + 2));
368: } elsif ($ind_slash != -1 && $ind_sup != -1 && $ind_slash == $ind_sup - 1) {
369: $type = 'empty';
370: if ($ind_space != -1 && $ind_space < $ind_sup) {
371: $tag = substr($line, $j2 + 1, $ind_space - ($j2 + 1));
372: } else {
373: $tag = substr($line, $j2 + 1, $ind_slash - ($j2 + 1));
374: }
375: } elsif ($ind_sup != -1) {
376: $type = 'start';
377: if ($ind_space != -1 && $ind_space < $ind_sup) {
378: $tag = substr($line, $j2 + 1, $ind_space - ($j2 + 1));
379: } else {
380: $tag = substr($line, $j2 + 1, $ind_sup - ($j2 + 1));
381: }
382: } else {
383: $tag = ''
384: }
385: if ($tag ne '') {
386: return ($tag, $type, $i2, $j2);
387: }
388: $j2 = index($line, '<', $j2 + 1);
389: }
390: $i2++;
391: $j2 = 0;
392: }
393: return ('', '', 0, 0);
394: }
395:
396: ##
397: # Tests if a string is in an array, ignoring case
398: ##
399: sub in_array_ignore_case {
400: my ($array, $value) = @_;
401: my $lcvalue = lc($value);
402: foreach my $v (@{$array}) {
403: if (lc($v) eq $lcvalue) {
404: return 1;
405: }
406: }
407: return 0;
408: }
409:
410: 1;
411: __END__
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to pre_xml.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / modules / damieng / clean_xml