source: main/trunk/model-sites-dev/von-sparql/collect/nz-natlib-cat/pre-import/HUNT-FOR-NON-ASCII.pl@ 36291

use strict;

use Encode qw(decode encode);

binmode STDERR, ":encoding(utf8)";
binmode STDOUT, ":encoding(utf8)";

my $DEBUG = 0;

sub debug_unicode_string
{
    join("",
         map { $_ > 127 ?                      # if wide character...
                   sprintf("\\x{%04X}", $_) :  # \x{...}
                   chr($_)          
               } unpack("U*", $_[0]));         # unpack Unicode characters
}


sub debug_unicode_string_bytes
{
    join("",
         map { $_ > 127 ?                      # if wide character...
                   sprintf("\\u{%02X}", $_) :  # \x{...}
                   chr($_)          
               } unpack("U*", $_[0]));         # unpack Unicode characters
}


# Returns true (1) if the given string is utf8 and false (0) if it isn't.
# Does not modify the string parameter.
sub check_is_utf8 {
    my $value=shift;

    if (!defined($value)) {
    return 0; # not utf8 because it is undefined
    }

    $value =~ m/^/g; # to set \G
    while ($value =~ m!\G.*?([\x80-\xff]+)!sg) {
    my $highbytes=$1;
    # make sure this block of high bytes is utf-8
    $highbytes =~ /^/g; # set pos()
    while ($highbytes =~
        m!\G (?: [\xc0-\xdf][\x80-\xbf]   | # 2 byte utf-8
            [\xe0-\xef][\x80-\xbf]{2} | # 3 byte
            [\xf0-\xf7][\x80-\xbf]{3} | # 4 byte
            [\xf8-\xfb][\x80-\xbf]{4} | # 5 byte
            [\xfc-\xfd][\x80-\xbf]{5} | # 6 byte
            )*([\x80-\xff])? !xg
        ) {
        my $badbyte=$1;
        if (defined $badbyte) { # not end of string
        return 0; # non-utf8 found
        } 
    }
    }
    
    return 1;
}


sub unescapeEntities
{
    my ($line) = @_;
    
    # unescape reserved entities
    $line =~ s/'/'/g;
    $line =~ s/"/"/g;
    $line =~ s/&lt;/</g;
    $line =~ s/&gt;/>/g;
    $line =~ s/&amp;/&/g;

    return $line;
}


sub getTagPairs
{
    my ($line,$opt_filter) = @_;

    my @filtered_tag_pairs = ();
    
    my @tag_pairs = split(/(<[^>]*>)/,$line);
    shift @tag_pairs; # given the split RE, there's always an empty-string first match

    my $tag_pairs_len = scalar(@tag_pairs);
    
    for (my $i=0; $i<$tag_pairs_len; $i+=2) {
    my $tag = $tag_pairs[$i];
    my $inner_text = $tag_pairs[$i+1];
    $inner_text = "" if $inner_text eq "\n";

    if (!defined $opt_filter) {
        push(@filtered_tag_pairs,$tag,$inner_text);
    }
    elsif ($tag =~ m/^<$opt_filter/i) {
        push(@filtered_tag_pairs,$tag,$inner_text);
    }   
    }
    
    
    return \@filtered_tag_pairs;
}

sub getInnerTextFromTags
{
    my ($line,$opt_filter) = @_;

    my @inner_text_vals = ();
    
    my $filtered_tag_pairs = getTagPairs($line,$opt_filter);
        
    my $filtered_tag_pairs_len = scalar(@$filtered_tag_pairs);

    for (my $i=0; $i<$filtered_tag_pairs_len; $i+=2) {
    my $tag = $filtered_tag_pairs->[$i];
    my $inner_text = $filtered_tag_pairs->[$i+1];
    
    if ($inner_text ne "") {
        my $inner_text_unescaped = unescapeEntities($inner_text);
        
        push(@inner_text_vals,$inner_text_unescaped);
    }   
    }

    my $inner_text_vals_len = scalar(@inner_text_vals);

    if ($DEBUG) {
    if ($inner_text_vals_len > 0) {
        print "Filtered tags, innner text: [\n";
        map {print "    $_\n"} @inner_text_vals;
        print "]\n";
    }
    }
    
    return \@inner_text_vals;
}

sub processInnerTextVals
{
    my ($inner_text_vals,$line_num) = @_;

    for my $line (@{$inner_text_vals}) {
    
    my $is_utf8 = check_is_utf8($line);
    if ($is_utf8) {
        # if ($line =~ m/[^[:ascii:]]/) {
    
        # from_to($line, "iso-8859-1", "UTF-8");   #1 -- does not turn on unicode-aware flag
        # my $line_utf8 = decode("iso-8859-1", $line);  #2 -- does turn on unicode-aware flag
    
        my $line_utf8 = decode("utf8", $line);  #2 -- does turn on unicode-aware flag
        
        if ($line =~ m/[^\x{00}-\x{7F}]/) {
        print "$line_num:\tUses Non-ASCII chars:\t$line_utf8\n";
        print "            UTF8 Bytes > 127:\t", debug_unicode_string_bytes($line), "\n";
        print "    Unicode codepoints > 127:\t", debug_unicode_string($line_utf8), "\n";
        print "-" x 20, "\n";
        }
    }
    else {
        # my $line_utf8 = decode("utf8", $line);  # decode() turns on unicode-aware flag
        
        print "$line_num:\tNOT VALID UTF8\n";
        print "            UTF8 Bytes > 127:\t", debug_unicode_string_bytes($line), "\n";
        print "           As Latin1 mapping:\t$line", "\n";
        print "-" x 20, "\n";
    }
    }

}

sub processLine
{
    my ($line_num,$line) = @_;

    my $inner_text_vals = getInnerTextFromTags($line,"subfield|marc:subfield");

    processInnerTextVals($inner_text_vals,$line_num);
    
#    # strip out tags
#    $line =~ s/<[^>]*>/ /g;
        
#    # unescape reserved entities
#    $line = unescapeEntities($line);
    
}

sub processFile
{
    my ($filename) = @_;
    

    my $line_num = 0;
    
    #if (open FILE, '<:encoding(utf8)', $filename) {
    # Explicitly forcing to Latin1 causes the text file to be read in a 1 byte per char
    if (open FILE, "< :encoding(Latin1)", $filename) {
    #if (open FILE, $filename) {
    while(<FILE>) {
        my $line .= $_;
        $line_num++;
        
        processLine($line_num,$line)
    }
    close FILE;
    }
    else {
    print STDERR "Failed to open '$filename'\n";
    print $!;
    }
}

my $filename = $ARGV[0];


processFile($filename);


#perl -ne 'print if /[^[:ascii:]]/' $*
    
#<subfield code="a">Ren

#    <subfield code="a">Ren