File:  [LON-CAPA] / loncom / homework / cleanxml / pre_xml.pm
Revision 1.2: download - view: text, annotated - select for diffs
Wed Jan 6 16:44:32 2016 UTC (6 years, 10 months ago) by damieng
Branches: MAIN
CVS tags: version_2_12_X, HEAD
Added Daxe editing for HTML documents, fixed issues with case mixing in task documents

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>