|
|
|
@ -0,0 +1,996 @@ |
|
|
|
package File::FormatIdentification::Pronom; |
|
|
|
|
|
|
|
use 5.024001; |
|
|
|
use strict; |
|
|
|
use warnings; |
|
|
|
use diagnostics; |
|
|
|
use XML::LibXML; |
|
|
|
use Carp; |
|
|
|
use List::Util qw( none first ); |
|
|
|
use Scalar::Util; |
|
|
|
use YAML::XS; |
|
|
|
use File::FormatIdentification::Regex; |
|
|
|
use Moose; |
|
|
|
|
|
|
|
our $VERSION = '0.01'; |
|
|
|
|
|
|
|
# Preloaded methods go here. |
|
|
|
# flattens a regex-structure to a regex-string, expects a signature-pattern and a list of regex-structures |
|
|
|
# returns regex |
|
|
|
# |
|
|
|
no warnings 'recursion'; |
|
|
|
|
|
|
|
sub _flatten_rx_recursive ($$$@) { |
|
|
|
my $regex = shift; |
|
|
|
my $lastpos = shift; |
|
|
|
my $open_brackets = shift; |
|
|
|
my @rx_groups = @_; |
|
|
|
my $rx = shift @rx_groups; |
|
|
|
|
|
|
|
#use Data::Printer; |
|
|
|
#say "_flatten_rx_recursive"; |
|
|
|
#p( @rx_groups ); |
|
|
|
#p( $rx ); |
|
|
|
my $bracket_symbol = "("; |
|
|
|
if ( !defined $regex ) { confess; } |
|
|
|
|
|
|
|
if ( !defined $rx ) { # do nothing |
|
|
|
while ( $open_brackets > 0 ) { |
|
|
|
$regex .= ")"; |
|
|
|
$open_brackets--; |
|
|
|
} |
|
|
|
} |
|
|
|
else { |
|
|
|
my $pos_diff = $rx->{position} - $lastpos; |
|
|
|
my $local_regex = $rx->{regex}; |
|
|
|
if ( !defined $local_regex ) { |
|
|
|
$local_regex = ''; |
|
|
|
} |
|
|
|
if ( 0 == $pos_diff ) { |
|
|
|
|
|
|
|
# TODO: |
|
|
|
File::FormatIdentification::Regex::simplify_two_or_combined_regex( |
|
|
|
$regex, $local_regex ); |
|
|
|
$regex = |
|
|
|
&_flatten_rx_recursive( "$regex|$local_regex", $lastpos, |
|
|
|
$open_brackets, @rx_groups ); |
|
|
|
} |
|
|
|
elsif ( $pos_diff > 0 ) { # is deeper |
|
|
|
# look a head, if same pos found, then use bracket, otherwise not |
|
|
|
if ( |
|
|
|
( |
|
|
|
scalar @rx_groups > 0 |
|
|
|
&& ( $rx_groups[0]->{position} == $rx->{position} ) |
|
|
|
) |
|
|
|
|| $pos_diff > 1 |
|
|
|
) |
|
|
|
{ # use ( |
|
|
|
$regex = &_flatten_rx_recursive( |
|
|
|
"$regex" . ( $bracket_symbol x $pos_diff ) . $local_regex, |
|
|
|
$rx->{position}, $open_brackets += $pos_diff, @rx_groups ); |
|
|
|
} |
|
|
|
else { |
|
|
|
$regex = &_flatten_rx_recursive( |
|
|
|
"$regex$local_regex", $rx->{position}, |
|
|
|
$open_brackets, @rx_groups |
|
|
|
); |
|
|
|
} ## end else [ if ( scalar @rx_groups...)] |
|
|
|
} |
|
|
|
elsif ( $pos_diff < 0 ) { # is higher |
|
|
|
$regex = &_flatten_rx_recursive( |
|
|
|
"$regex)$local_regex", |
|
|
|
$rx->{position}, |
|
|
|
$open_brackets - 1, #($rx->{position} - $lastpos), |
|
|
|
@rx_groups |
|
|
|
); |
|
|
|
} |
|
|
|
else { |
|
|
|
confess |
|
|
|
"FL: pos=$rx->{position} lastpos=$lastpos regex='$regex' open=$open_brackets\n"; |
|
|
|
} |
|
|
|
} |
|
|
|
return $regex; |
|
|
|
} ## end sub _flatten_rx_recursive ($$$@) |
|
|
|
use warnings 'recursion'; |
|
|
|
|
|
|
|
sub _flatten_rx ($@) { |
|
|
|
my $regex = shift; |
|
|
|
my @rx_groups = @_; |
|
|
|
|
|
|
|
#say "calling flatten_rx with regex=$regex quality=$quality"; |
|
|
|
#use Data::Printer; |
|
|
|
#p( @rx_groups ); |
|
|
|
$regex = _flatten_rx_recursive( $regex, 0, 0, @rx_groups ); |
|
|
|
return $regex; |
|
|
|
} ## end sub _flatten_rx ($@) |
|
|
|
|
|
|
|
# expands pattern of form "FFFB[10:EB]" to FFFB10, FFFB11, ... FFFBEB |
|
|
|
sub _expand_pattern ($) { |
|
|
|
my $pattern = shift; |
|
|
|
$pattern =~ s/\[!/[^/g; |
|
|
|
$pattern =~ s/([0-9A-F]{2}):([0-9A-F]{2})\]/$1-$2]/g; |
|
|
|
$pattern =~ s/([0-9A-F]{2})/\\x$1/g; |
|
|
|
|
|
|
|
# substitute hex with printable ASCII-Output |
|
|
|
$pattern =~ s#\\x(3[0-9]|[46][1-9A-F]|[57][0-9A])#chr( hex($1) );#egs; |
|
|
|
return $pattern; |
|
|
|
} ## end sub _expand_pattern ($) |
|
|
|
|
|
|
|
# expands offsets min,max to regex ".{$min,$max}" and uses workarounds if $min or $max exceeds 32766 |
|
|
|
sub _expand_offsets($$) { |
|
|
|
my $minoffset = shift; |
|
|
|
my $maxoffset = shift; |
|
|
|
my $byte = |
|
|
|
'.'; # HINT: needs the character set modifier "aa" in $foo=~m/$regex/aa |
|
|
|
#my $byte = '[\x00-\xff]'; |
|
|
|
my $offset_expanded = ""; |
|
|
|
if ( ( ( not defined $minoffset ) || ( length($minoffset) == 0 ) ) |
|
|
|
&& ( ( not defined $maxoffset ) || ( length($maxoffset) == 0 ) ) ) |
|
|
|
{ |
|
|
|
$offset_expanded = ""; |
|
|
|
} |
|
|
|
elsif (( defined $minoffset ) |
|
|
|
&& ( length($minoffset) > 0 ) |
|
|
|
&& ( defined $maxoffset ) |
|
|
|
&& ( length($maxoffset) > 0 ) |
|
|
|
&& ( $minoffset == $maxoffset ) ) |
|
|
|
{ |
|
|
|
if ( $minoffset > 0 ) { |
|
|
|
my $maxloops = int( $maxoffset / 32766 ); |
|
|
|
my $maxresidual = $maxoffset % 32766; |
|
|
|
for ( my $i = 0 ; $i < $maxloops ; $i++ ) { |
|
|
|
$offset_expanded .= $byte . "{32766}"; |
|
|
|
} |
|
|
|
$offset_expanded .= $byte . "{$maxresidual}"; |
|
|
|
} ## end if ( $minoffset > 0 ) |
|
|
|
} |
|
|
|
else { |
|
|
|
|
|
|
|
# workaround, because perl quantifier limits, |
|
|
|
# calc How many repetitions we need! Both offsets should be less than 32766 |
|
|
|
#TODO: check if this comes from Droid or is calculated |
|
|
|
|
|
|
|
my $mintmp = 0; |
|
|
|
my $maxtmp = 0; |
|
|
|
if ( defined $minoffset && ( length($minoffset) > 0 ) ) { |
|
|
|
$mintmp = $minoffset; |
|
|
|
} |
|
|
|
if ( defined $maxoffset && ( length($maxoffset) > 0 ) ) { |
|
|
|
$maxtmp = $maxoffset; |
|
|
|
} |
|
|
|
|
|
|
|
my $maxloops; |
|
|
|
if ( $maxtmp >= $mintmp ) { |
|
|
|
$maxloops = int( $maxtmp / 32766 ); |
|
|
|
} |
|
|
|
else { |
|
|
|
$maxloops = int( $mintmp / 32766 ); |
|
|
|
} |
|
|
|
my $maxresidual = $maxtmp % 32766; |
|
|
|
my $minresidual = $mintmp % 32766; |
|
|
|
|
|
|
|
#say "\tMaxloops=$maxloops maxres = $maxresidual minres=$minresidual"; |
|
|
|
my @offsets; |
|
|
|
my $minstr = ""; |
|
|
|
my $maxstr = ""; |
|
|
|
if ( defined $minoffset && length($minoffset) > 0 ) { |
|
|
|
$minstr = $minresidual; |
|
|
|
$mintmp = $mintmp - $minresidual; |
|
|
|
} |
|
|
|
|
|
|
|
for ( my $i = 0 ; $i <= $maxloops ; $i++ ) { |
|
|
|
|
|
|
|
# loop, so we assure the special handling of residuals |
|
|
|
if ( $maxtmp > $maxresidual ) { |
|
|
|
$maxstr = 32766; |
|
|
|
} |
|
|
|
elsif ( $maxtmp < 0 ) { |
|
|
|
$maxstr = 0; |
|
|
|
} |
|
|
|
else { |
|
|
|
$maxstr = $maxresidual; |
|
|
|
} |
|
|
|
if ( $mintmp > $minresidual ) { |
|
|
|
$minstr = 32766; |
|
|
|
} |
|
|
|
elsif ( $mintmp < 0 ) { |
|
|
|
$minstr = 0; |
|
|
|
} |
|
|
|
else { |
|
|
|
$minstr = $minresidual; |
|
|
|
} |
|
|
|
#### handle residuals |
|
|
|
if ( $i == 0 ) { |
|
|
|
$minstr = $minresidual; |
|
|
|
$mintmp = $mintmp - $minresidual; |
|
|
|
} |
|
|
|
elsif ( $i == $maxloops ) { |
|
|
|
$maxstr = $maxresidual; |
|
|
|
$maxtmp = $maxtmp - $maxresidual; |
|
|
|
} |
|
|
|
|
|
|
|
# mark offsets |
|
|
|
my $tmp; |
|
|
|
$tmp->{minoffset} = $minstr; |
|
|
|
$tmp->{maxoffset} = $maxstr; |
|
|
|
push @offsets, $tmp; |
|
|
|
} ## end for ( my $i = 0 ; $i <=...) |
|
|
|
my @filtered = map { |
|
|
|
if ( !defined $maxoffset || length($maxoffset) == 0 ) { |
|
|
|
$_->{maxoffset} = ""; |
|
|
|
} |
|
|
|
if ( !defined $minoffset || length($minoffset) == 0 ) { |
|
|
|
$_->{minoffset} = ""; |
|
|
|
} |
|
|
|
$_; |
|
|
|
} @offsets; |
|
|
|
foreach my $tmp (@filtered) { |
|
|
|
|
|
|
|
# ? at the end - means non-greedy |
|
|
|
#$offset_expanded .= $byte."{" . $tmp->{minoffset} . "," . $tmp->{maxoffset} . "}?"; |
|
|
|
$offset_expanded .= |
|
|
|
$byte . "{" . $tmp->{minoffset} . "," . $tmp->{maxoffset} . "}"; |
|
|
|
} ## end foreach my $tmp (@filtered) |
|
|
|
} ## end else [ if ( ( ( not defined $minoffset...)))] |
|
|
|
|
|
|
|
#say "DEBUG: minoffset='$minoffset' maxoffset='$maxoffset' --> offset_expanded='$offset_expanded'"; |
|
|
|
|
|
|
|
# minimization steps |
|
|
|
$offset_expanded =~ s#{0,}#*#g; |
|
|
|
$offset_expanded =~ s#{1,}#+#g; |
|
|
|
$offset_expanded =~ s#{0,1}#?#g; |
|
|
|
return $offset_expanded; |
|
|
|
} ## end sub _expand_offsets($$) |
|
|
|
|
|
|
|
# got XPath-object and returns a regex-structure as hashref |
|
|
|
sub _parse_fragments ($) { |
|
|
|
my $fq = shift; |
|
|
|
my $position = $fq->getAttribute('Position'); |
|
|
|
my $minoffset = $fq->getAttribute('MinOffset'); |
|
|
|
my $maxoffset = $fq->getAttribute('MaxOffset'); |
|
|
|
my $rx = $fq->textContent; |
|
|
|
my $expanded = _expand_pattern($rx); |
|
|
|
my $ret; |
|
|
|
$ret->{position} = $position; |
|
|
|
$ret->{direction} = "left"; |
|
|
|
$ret->{regex} = ""; |
|
|
|
|
|
|
|
my ($offset_expanded) = _expand_offsets( $minoffset, $maxoffset ); |
|
|
|
|
|
|
|
if ( $fq->localname eq "LeftFragment" ) { |
|
|
|
$ret->{direction} = "left"; |
|
|
|
$ret->{regex} = "($expanded)$offset_expanded"; |
|
|
|
} |
|
|
|
elsif ( $fq->localname eq "RightFragment" ) { |
|
|
|
$ret->{direction} = "right"; |
|
|
|
$ret->{regex} = "$offset_expanded($expanded)"; |
|
|
|
} |
|
|
|
|
|
|
|
#say "pF: rx=$rx expanded=$expanded offset=$offset_expanded"; |
|
|
|
return $ret; |
|
|
|
} ## end sub _parse_fragments ($) |
|
|
|
|
|
|
|
# got XPath-object and search direction and returns a regex-structure as hashref |
|
|
|
sub _parse_subsequence ($$) { |
|
|
|
my $ssq = shift; |
|
|
|
my $dir = shift; |
|
|
|
my $position = $ssq->getAttribute('Position'); |
|
|
|
my $minoffset = $ssq->getAttribute('SubSeqMinOffset'); |
|
|
|
my $maxoffset = $ssq->getAttribute('SubSeqMaxOffset'); |
|
|
|
|
|
|
|
my $rx = $ssq->getElementsByTagName('Sequence')->get_node(1)->textContent; |
|
|
|
|
|
|
|
my @lnodes = $ssq->getElementsByTagName('LeftFragment'); |
|
|
|
my @rnodes = $ssq->getElementsByTagName('RightFragment'); |
|
|
|
my @lrx_fragments = map { _parse_fragments($_) } @lnodes; |
|
|
|
my @rrx_fragments = map { _parse_fragments($_) } @rnodes; |
|
|
|
my $lregex = _flatten_rx( "", @lrx_fragments ); |
|
|
|
my $rregex = _flatten_rx( "", @rrx_fragments ); |
|
|
|
my $expanded = _expand_pattern($rx); |
|
|
|
|
|
|
|
#if ( length($minoffset) > 0 |
|
|
|
# && length($maxoffset) > 0 |
|
|
|
# && $minoffset > $maxoffset ) { |
|
|
|
# confess( |
|
|
|
#"parse_subsequence: Maxoffset=$maxoffset < Minoffset=$minoffset! regex= '$rx'" |
|
|
|
# ); |
|
|
|
# } ## end if ( length($minoffset...)) |
|
|
|
|
|
|
|
my $offset_expanded = _expand_offsets( $minoffset, $maxoffset ); |
|
|
|
my $prefix; |
|
|
|
my $suffix; |
|
|
|
my $ret; |
|
|
|
my $regex; |
|
|
|
if ( !defined $dir || length($dir) == 0 ) { |
|
|
|
$regex = join( "", $lregex, $expanded, $rregex ); |
|
|
|
} |
|
|
|
elsif ( $dir eq "BOFoffset" ) { |
|
|
|
$regex = |
|
|
|
join( "", $offset_expanded, "(", $lregex, $expanded, $rregex, ")" ); |
|
|
|
} |
|
|
|
elsif ( $dir eq "EOFoffset" ) { |
|
|
|
$regex = |
|
|
|
join( "", "(", $lregex, $expanded, $rregex, ")", $offset_expanded ); |
|
|
|
} |
|
|
|
else { |
|
|
|
warn "unknown reference '$dir' found\n"; |
|
|
|
$regex = join( "", $lregex, $expanded, $rregex ); |
|
|
|
} |
|
|
|
$ret->{regex} = |
|
|
|
File::FormatIdentification::Regex::peep_hole_optimizer($regex); |
|
|
|
$ret->{position} = $position; |
|
|
|
|
|
|
|
return $ret; |
|
|
|
} ## end sub _parse_subsequence ($$) |
|
|
|
|
|
|
|
# got XPath-object and returns regex-string |
|
|
|
sub _parse_bytesequence ($) { |
|
|
|
my $bsq = shift; |
|
|
|
|
|
|
|
#say "rx_groups in parse_byte_sequence:"; |
|
|
|
my $reference = $bsq->getAttribute('Reference'); |
|
|
|
; # if BOFoffset -> anchored begin of file, EOFofset -> end of file |
|
|
|
my @nodes = $bsq->getElementsByTagName('SubSequence'); |
|
|
|
my @rx_groups = map { _parse_subsequence( $_, $reference ) } @nodes; |
|
|
|
my $expanded = ""; |
|
|
|
my $regex_flattened = _flatten_rx( $expanded, @rx_groups ); |
|
|
|
|
|
|
|
#my $ro = Regexp::Optimizer->new; |
|
|
|
#my $ro = Regexp::Assemble->new; |
|
|
|
#$ro->add( $regex_flattened); |
|
|
|
#$regex_flattened = $ro->as_string($regex_flattened); |
|
|
|
#$regex_flattened = $ro->re; |
|
|
|
my $regex; |
|
|
|
if ( !defined $reference || 0 == length($reference) ) { |
|
|
|
$regex = "$regex_flattened"; |
|
|
|
} |
|
|
|
elsif ( $reference eq "BOFoffset" ) { |
|
|
|
$regex = "\\A$regex_flattened"; |
|
|
|
} |
|
|
|
elsif ( $reference eq "EOFoffset" ) { |
|
|
|
$regex = "$regex_flattened\\Z"; |
|
|
|
} |
|
|
|
else { |
|
|
|
warn "unknown reference '$reference' found\n"; |
|
|
|
$regex = "$regex_flattened"; |
|
|
|
} |
|
|
|
|
|
|
|
use Regexp::Optimizer; |
|
|
|
my $ro = Regexp::Optimizer->new; |
|
|
|
|
|
|
|
#say "regex='$regex'"; |
|
|
|
#$regex = $ro->as_string( $regex ); |
|
|
|
return $regex; |
|
|
|
} ## end sub _parse_bytesequence ($) |
|
|
|
|
|
|
|
# ($%signatures, $%internal) = parse_signaturefile( $file ) |
|
|
|
sub _parse_signaturefile($) { |
|
|
|
my $pronomfile = shift; |
|
|
|
my %signatures; |
|
|
|
|
|
|
|
# hash{internalid}->{regex} = $regex |
|
|
|
# ->{signature} = $signature |
|
|
|
my %internal_signatures; |
|
|
|
|
|
|
|
my $dom = XML::LibXML->load_xml( location => $pronomfile ); |
|
|
|
$dom->indexElements(); |
|
|
|
my $xp = XML::LibXML::XPathContext->new($dom); |
|
|
|
$xp->registerNs( 'droid', |
|
|
|
'http://www.nationalarchives.gov.uk/pronom/SignatureFile' ); |
|
|
|
|
|
|
|
# find Fileformats |
|
|
|
#my $tmp = $xp->find('/*[local-name() = "FFSignatureFile"]')->get_node(1); |
|
|
|
#say "E:", $tmp->nodeName; |
|
|
|
#say "EXISTS:", $xp->exists('/droid:FFSignatureFile'); |
|
|
|
#say "EXISTS2", $xp->exists('/droid:FFSignatureFile/droid:FileFormatCollection/droid:FileFormat'); |
|
|
|
|
|
|
|
my $fmts = $xp->find( |
|
|
|
'/*[local-name() = "FFSignatureFile"]/*[local-name() = "FileFormatCollection"]/*[local-name() = "FileFormat"]' |
|
|
|
); |
|
|
|
foreach my $fmt ( $fmts->get_nodelist() ) { |
|
|
|
my $id = $fmt->getAttribute('ID'); |
|
|
|
my $mimetype = $fmt->getAttribute('MIMEtype'); |
|
|
|
my $name = $fmt->getAttribute('Name'); |
|
|
|
my $puid = $fmt->getAttribute('PUID'); |
|
|
|
my $version = $fmt->getAttribute('Version'); |
|
|
|
# |
|
|
|
|
|
|
|
## |
|
|
|
my @extensions = |
|
|
|
map { $_->textContent() } $fmt->getElementsByTagName('Extension'); |
|
|
|
my @internalsignatures = |
|
|
|
map { $_->textContent() } |
|
|
|
$fmt->getElementsByTagName('InternalSignatureID'); |
|
|
|
my @haspriorityover = map { $_->textContent() } |
|
|
|
$fmt->getElementsByTagName('HasPriorityOverFileFormatID'); |
|
|
|
$signatures{$id}->{mimetype} = $mimetype; |
|
|
|
$signatures{$id}->{name} = $name; |
|
|
|
$signatures{$id}->{puid} = $puid; |
|
|
|
$signatures{$id}->{version} = $version; # optional |
|
|
|
$signatures{$id}->{extensions} = \@extensions; |
|
|
|
$signatures{$id}->{internal_signatures} = \@internalsignatures; |
|
|
|
|
|
|
|
foreach my $prio (@haspriorityover) { |
|
|
|
$signatures{$id}->{priorityover}->{$prio} = 1; |
|
|
|
} |
|
|
|
|
|
|
|
foreach my $internal (@internalsignatures) { |
|
|
|
$internal_signatures{$internal}->{signature} = $id; |
|
|
|
} |
|
|
|
} ## end foreach my $fmt ( $fmts->get_nodelist...) |
|
|
|
|
|
|
|
# find InternalSignatures |
|
|
|
my $sigs = |
|
|
|
$xp->find( |
|
|
|
'/*[local-name() = "FFSignatureFile"]/*[local-name() = "InternalSignatureCollection"]/*[local-name() = "InternalSignature"]' |
|
|
|
); |
|
|
|
|
|
|
|
foreach my $sig ( $sigs->get_nodelist() ) { |
|
|
|
|
|
|
|
my $id = $sig->getAttribute('ID'); |
|
|
|
my $specificity = $sig->getAttribute('Specificity'); |
|
|
|
$internal_signatures{$id}->{specificity} = $specificity; |
|
|
|
|
|
|
|
#p( $sig->toString() ); |
|
|
|
my @nodes = $sig->getElementsByTagName('ByteSequence'); |
|
|
|
|
|
|
|
#p( @nodes ); |
|
|
|
my @rx_groups = map { _parse_bytesequence($_) } @nodes; |
|
|
|
my @rx_quality = |
|
|
|
map { File::FormatIdentification::Regex::calc_quality($_); } |
|
|
|
@rx_groups; |
|
|
|
|
|
|
|
$internal_signatures{$id}->{regex} = \@rx_groups; |
|
|
|
$internal_signatures{$id}->{quality} = \@rx_quality; |
|
|
|
} ## end foreach my $sig ( $sigs->get_nodelist...) |
|
|
|
|
|
|
|
return ( \%signatures, \%internal_signatures ); |
|
|
|
} ## end sub _parse_signaturefile($) |
|
|
|
|
|
|
|
sub uniq_signature_ids_by_priority { |
|
|
|
my $self = shift; |
|
|
|
my @signatures = @_; |
|
|
|
my %found_signature_ids; |
|
|
|
|
|
|
|
# which PUIDs are in list? |
|
|
|
foreach my $signatureid (@signatures) { |
|
|
|
if ( defined $signatureid ) { |
|
|
|
$found_signature_ids{$signatureid} = 1; |
|
|
|
} |
|
|
|
} |
|
|
|
|
|
|
|
# remove all signatures when actual signature has priority over |
|
|
|
foreach my $signatureid ( keys %found_signature_ids ) { |
|
|
|
foreach my $priority_over_sid ( |
|
|
|
keys %{ $self->{signatures}->{$signatureid}->{priorityover} } ) |
|
|
|
{ |
|
|
|
if ( exists $found_signature_ids{$priority_over_sid} ) { |
|
|
|
delete $found_signature_ids{$priority_over_sid}; |
|
|
|
} |
|
|
|
} ## end foreach my $priority_over_sid... |
|
|
|
} ## end foreach my $signatureid ( keys...) |
|
|
|
|
|
|
|
# reduce list to all signatures with correct priority |
|
|
|
my @result = |
|
|
|
grep { defined $found_signature_ids{ $_->{signature} } } @signatures; |
|
|
|
return @result; |
|
|
|
} ## end sub uniq_signature_ids_by_priority |
|
|
|
|
|
|
|
has 'droid_signature_filename' => ( |
|
|
|
is => 'ro', |
|
|
|
required => 1, |
|
|
|
reader => 'get_droid_signature_filename', |
|
|
|
trigger => sub { |
|
|
|
my $self = shift; |
|
|
|
|
|
|
|
#say "TRIGGER"; |
|
|
|
my $yaml_file = $self->get_droid_signature_filename() . ".yaml"; |
|
|
|
if ( $self->{auto_load} && -e $yaml_file ) { |
|
|
|
$self->load_from_yamlfile($yaml_file); |
|
|
|
} |
|
|
|
else { |
|
|
|
my ( $signatures, $internal_signatures ) = |
|
|
|
_parse_signaturefile( $self->{droid_signature_filename} ); |
|
|
|
$self->{signatures} = $signatures; |
|
|
|
$self->{internal_signatures} = $internal_signatures; |
|
|
|
|
|
|
|
#die; |
|
|
|
if ( $self->{auto_store} ) { |
|
|
|
$self->save_as_yamlfile($yaml_file); |
|
|
|
} |
|
|
|
} ## end else [ if ( $self->{auto_load...})] |
|
|
|
foreach my $s ( keys %{ $self->{signatures} } ) { |
|
|
|
my $puid = $self->{signatures}->{$s}->{puid}; |
|
|
|
if ( defined $puid && length($puid) > 0 ) { |
|
|
|
$self->{puids}->{$puid} = $s; |
|
|
|
} |
|
|
|
} |
|
|
|
} |
|
|
|
); |
|
|
|
|
|
|
|
sub save_as_yamlfile { |
|
|
|
my $self = shift; |
|
|
|
my $filename = shift; |
|
|
|
my @res; |
|
|
|
push @res, $self->{signatures}; |
|
|
|
push @res, $self->{internal_signatures}; |
|
|
|
YAML::XS::DumpFile( "$filename", @res ); |
|
|
|
} ## end sub save_as_yamlfile |
|
|
|
|
|
|
|
sub load_from_yamlfile { |
|
|
|
my $self = shift; |
|
|
|
my $filename = shift; |
|
|
|
my ( $sig, $int ) = YAML::XS::LoadFile($filename); |
|
|
|
$self->{signatures} = $sig; |
|
|
|
$self->{internal_signatures} = $int; |
|
|
|
} ## end sub load_from_yamlfile |
|
|
|
|
|
|
|
has 'auto_store' => ( |
|
|
|
is => 'ro', |
|
|
|
default => 1, |
|
|
|
); |
|
|
|
|
|
|
|
has 'auto_load' => ( |
|
|
|
is => 'ro', |
|
|
|
default => 1, |
|
|
|
); |
|
|
|
|
|
|
|
sub get_all_signature_ids { |
|
|
|
my $self = shift; |
|
|
|
my @sigs = sort { $a <=> $b } keys %{ $self->{signatures} }; |
|
|
|
return @sigs; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_signature_id_by_puid { |
|
|
|
my $self = shift; |
|
|
|
my $puid = shift; |
|
|
|
my $sig = $self->{puids}->{$puid}; |
|
|
|
no warnings; |
|
|
|
return $sig; |
|
|
|
use warnings; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_internal_ids_by_puid { |
|
|
|
my $self = shift; |
|
|
|
my $puid = shift; |
|
|
|
my $sig = $self->get_signature_id_by_puid($puid); |
|
|
|
my @ids = (); |
|
|
|
if ( defined $sig ) { |
|
|
|
@ids = grep { defined $_ } |
|
|
|
@{ $self->{signatures}->{$sig}->{internal_signatures} }; |
|
|
|
} |
|
|
|
return @ids; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_file_endings_by_puid { |
|
|
|
my $self = shift; |
|
|
|
my $puid = shift; |
|
|
|
my $sig = $self->get_signature_id_by_puid($puid); |
|
|
|
my @endings = (); |
|
|
|
if ( defined $sig ) { |
|
|
|
@endings = $self->{signatures}->{$sig}->{extensions}; |
|
|
|
} |
|
|
|
return @endings; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_all_internal_ids { |
|
|
|
my $self = shift; |
|
|
|
my @ids = sort { $a <=> $b } keys %{ $self->{internal_signatures} }; |
|
|
|
foreach my $id (@ids) { |
|
|
|
if ( !defined $id ) { confess("$id not defined") } |
|
|
|
} |
|
|
|
return @ids; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_all_puids { |
|
|
|
my $self = shift; |
|
|
|
my @ids = |
|
|
|
sort grep { defined $_ } |
|
|
|
map { $self->{signatures}->{$_}->{puid}; } |
|
|
|
grep { defined $_ } $self->get_all_signature_ids(); |
|
|
|
return @ids; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_regular_expressions_by_internal_id { |
|
|
|
my $self = shift; |
|
|
|
my $internalid = shift; |
|
|
|
if ( !defined $internalid ) { confess("internalid must exists!"); } |
|
|
|
my @rx = @{ $self->{internal_signatures}->{$internalid}->{regex} }; |
|
|
|
return @rx; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_all_regular_expressions { |
|
|
|
my $self = shift; |
|
|
|
my @ids = $self->get_all_internal_ids(); |
|
|
|
my @regexes = (); |
|
|
|
foreach my $id (@ids) { |
|
|
|
my @rx = $self->get_regular_expressions_by_internal_id($id); |
|
|
|
push @regexes, @rx; |
|
|
|
} |
|
|
|
my @ret = sort @regexes; |
|
|
|
return @ret; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_qualities_by_internal_id { |
|
|
|
my $self = shift; |
|
|
|
my $internalid = shift; |
|
|
|
if ( !defined $internalid ) { confess("internalid must exists!"); } |
|
|
|
my $value = $self->{internal_signatures}->{$internalid}->{quality}; |
|
|
|
if ( defined $value ) { |
|
|
|
return @{$value}; |
|
|
|
} |
|
|
|
return; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_signature_id_by_internal_id { |
|
|
|
my $self = shift; |
|
|
|
my $internalid = shift; |
|
|
|
if ( !defined $internalid ) { confess("internalid must exists!"); } |
|
|
|
return $self->{internal_signatures}->{$internalid}->{signature}; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_name_by_signature_id { |
|
|
|
my $self = shift; |
|
|
|
my $signature = shift; |
|
|
|
return $self->{signatures}->{$signature}->{name}; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_puid_by_signature_id { |
|
|
|
my $self = shift; |
|
|
|
my $signature = shift; |
|
|
|
return $self->{signatures}->{$signature}->{puid}; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_puid_by_internal_id { |
|
|
|
my $self = shift; |
|
|
|
my $internalid = shift; |
|
|
|
if ( !defined $internalid ) { confess("internalid must exists!"); } |
|
|
|
my $signature = $self->get_signature_id_by_internal_id($internalid); |
|
|
|
return $self->get_puid_by_signature_id($signature); |
|
|
|
} |
|
|
|
|
|
|
|
sub get_quality_sorted_internal_ids { |
|
|
|
my $self = shift; |
|
|
|
my @ids = sort { |
|
|
|
|
|
|
|
# sort by regexes |
|
|
|
my @a_rxq = @{ $self->{internal_signatures}->{$a}->{quality} }; |
|
|
|
my @b_rxq = @{ $self->{internal_signatures}->{$b}->{quality} }; |
|
|
|
my $aq = 0; |
|
|
|
foreach my $as (@a_rxq) { $aq += $as; } |
|
|
|
my $bq = 0; |
|
|
|
foreach my $bs (@b_rxq) { $bq += $bs; } |
|
|
|
|
|
|
|
#use Data::Printer; |
|
|
|
#p( $a ); |
|
|
|
#p( $aq ); |
|
|
|
$aq <=> $bq; |
|
|
|
} $self->get_all_internal_ids(); |
|
|
|
return @ids; |
|
|
|
} |
|
|
|
|
|
|
|
sub get_combined_regex_by_puid { |
|
|
|
my $self = shift; |
|
|
|
my $puid = shift; |
|
|
|
my @internals = $self->get_internal_ids_by_puid($puid); |
|
|
|
|
|
|
|
#use Data::Printer; |
|
|
|
#p( $puid ); |
|
|
|
#p( @internals ); |
|
|
|
my @regexes = map { |
|
|
|
my @regexes_per_internal = |
|
|
|
$self->get_regular_expressions_by_internal_id($_); |
|
|
|
my $combined = |
|
|
|
File::FormatIdentification::Regex::and_combine(@regexes_per_internal); |
|
|
|
|
|
|
|
#p( $combined ); |
|
|
|
$combined; |
|
|
|
} @internals; |
|
|
|
my $result = File::FormatIdentification::Regex::or_combine(@regexes); |
|
|
|
|
|
|
|
#p( $result ); |
|
|
|
return $result; |
|
|
|
} |
|
|
|
|
|
|
|
sub _prepare_statistics { |
|
|
|
my $self = shift; |
|
|
|
my $results; |
|
|
|
|
|
|
|
# count of PUIDs |
|
|
|
# count of internal ids (IDs per PUID) |
|
|
|
# count of regexes |
|
|
|
# count of file endings only |
|
|
|
# count of internal ids without PUID |
|
|
|
# larges and shortest regex |
|
|
|
# complex and simple regex |
|
|
|
# common regexes |
|
|
|
#say "stat"; |
|
|
|
my @puids = $self->get_all_puids(); |
|
|
|
my $puids = scalar(@puids); |
|
|
|
my @internals = $self->get_all_internal_ids(); |
|
|
|
my $internals = scalar(@internals); |
|
|
|
my $regexes = 0; |
|
|
|
my $fileendingsonly = 0; |
|
|
|
my @fileendingsonly = (); |
|
|
|
my $fileendings = 0; |
|
|
|
my $int_per_puid = 0; |
|
|
|
my $internal_without_puid = 0; |
|
|
|
my @internal_without_puid = (); |
|
|
|
my @quality_sorted_internal_ids = $self->get_quality_sorted_internal_ids(); |
|
|
|
my %uniq_regexes; |
|
|
|
|
|
|
|
foreach my $internalid (@internals) { |
|
|
|
my @regexes = |
|
|
|
$self->get_regular_expressions_by_internal_id($internalid); |
|
|
|
foreach my $rx (@regexes) { |
|
|
|
my @tmp = (); |
|
|
|
if ( exists $uniq_regexes{$rx} ) { |
|
|
|
@tmp = @{ $uniq_regexes{$rx} }; |
|
|
|
} |
|
|
|
push @tmp, $internalid; |
|
|
|
$uniq_regexes{$rx} = \@tmp; |
|
|
|
} |
|
|
|
|
|
|
|
$regexes += scalar(@regexes); |
|
|
|
my $sigid = $self->get_signature_id_by_internal_id($internalid); |
|
|
|
if ( !defined $sigid ) { |
|
|
|
$internal_without_puid++; |
|
|
|
push @internal_without_puid, $internalid; |
|
|
|
} |
|
|
|
} |
|
|
|
foreach my $puid (@puids) { |
|
|
|
my @ints = $self->get_internal_ids_by_puid($puid); |
|
|
|
my @fileendings = $self->get_file_endings_by_puid($puid); |
|
|
|
if ( 0 == scalar(@ints) ) { |
|
|
|
$fileendingsonly++; |
|
|
|
push @fileendingsonly, $puid; |
|
|
|
} |
|
|
|
else { |
|
|
|
$fileendings += scalar(@fileendings); |
|
|
|
$int_per_puid += scalar(@ints); |
|
|
|
} |
|
|
|
} |
|
|
|
foreach my $i (@quality_sorted_internal_ids) { |
|
|
|
my $regex = |
|
|
|
join( "#", $self->get_regular_expressions_by_internal_id($i) ); |
|
|
|
my $quality = join( " ", $self->get_qualities_by_internal_id($i) ); |
|
|
|
|
|
|
|
} |
|
|
|
|
|
|
|
$results->{filename} = $self->get_droid_signature_filename(); |
|
|
|
$results->{count_of_puids} = $puids; |
|
|
|
$results->{count_of_internal_ids} = $internals; |
|
|
|
$results->{count_of_regular_expressions} = $regexes; |
|
|
|
$results->{count_of_fileendings} = $fileendings; |
|
|
|
$results->{count_of_puid_with_fileendings_only} = $fileendingsonly; |
|
|
|
$results->{puids_with_fileendings_only} = \@fileendingsonly; |
|
|
|
$results->{count_of_orphaned_internal_ids} = $internal_without_puid; |
|
|
|
$results->{internal_ids_without_puids} = \@internal_without_puid; |
|
|
|
no warnings; |
|
|
|
|
|
|
|
for ( my $i = 0 ; $i <= 4 ; $i++ ) { |
|
|
|
my $best_quality_internal = pop @quality_sorted_internal_ids; |
|
|
|
if ( defined $best_quality_internal ) { |
|
|
|
my $best_quality = join( ";", |
|
|
|
$self->get_qualities_by_internal_id($best_quality_internal) ); |
|
|
|
my $best_puid = |
|
|
|
$self->get_puid_by_internal_id($best_quality_internal); |
|
|
|
my $best_name = |
|
|
|
$self->get_name_by_signature_id( |
|
|
|
$self->get_signature_id_by_internal_id($best_quality_internal) |
|
|
|
); |
|
|
|
my $best_regex = $self->get_combined_regex_by_puid($best_puid); |
|
|
|
$results->{nth_best_quality}->[$i]->{internal_id} = |
|
|
|
$best_quality_internal; |
|
|
|
$results->{nth_best_quality}->[$i]->{puid} = $best_puid; |
|
|
|
$results->{nth_best_quality}->[$i]->{name} = $best_name; |
|
|
|
$results->{nth_best_quality}->[$i]->{quality} = $best_quality; |
|
|
|
$results->{nth_best_quality}->[$i]->{combined_regex} = $best_regex; |
|
|
|
} |
|
|
|
} |
|
|
|
for ( my $i = 0 ; $i <= 4 ; $i++ ) { |
|
|
|
my $worst_quality_internal = shift @quality_sorted_internal_ids; |
|
|
|
if ( defined $worst_quality_internal ) { |
|
|
|
my $worst_quality = join( ";", |
|
|
|
$self->get_qualities_by_internal_id($worst_quality_internal) ); |
|
|
|
my $worst_puid = |
|
|
|
$self->get_puid_by_internal_id($worst_quality_internal); |
|
|
|
my $worst_name = |
|
|
|
$self->get_name_by_signature_id( |
|
|
|
$self->get_signature_id_by_internal_id($worst_quality_internal) |
|
|
|
); |
|
|
|
my $worst_regex = $self->get_combined_regex_by_puid($worst_puid); |
|
|
|
$results->{nth_worst_quality}->[$i]->{internal_id} = |
|
|
|
$worst_quality_internal; |
|
|
|
$results->{nth_worst_quality}->[$i]->{puid} = $worst_puid; |
|
|
|
$results->{nth_worst_quality}->[$i]->{name} = $worst_name; |
|
|
|
$results->{nth_worst_quality}->[$i]->{quality} = $worst_quality; |
|
|
|
$results->{nth_worst_quality}->[$i]->{combined_regex} = |
|
|
|
$worst_regex; |
|
|
|
} |
|
|
|
} |
|
|
|
my @multiple_used_regex = grep { |
|
|
|
my $tmp = $uniq_regexes{$_}; |
|
|
|
my @tmp = @{$tmp}; |
|
|
|
scalar(@tmp) > 1 |
|
|
|
} sort keys %uniq_regexes; |
|
|
|
$results->{count_of_multiple_used_regex} = scalar(@multiple_used_regex); |
|
|
|
for ( my $i = 0 ; $i <= $#multiple_used_regex ; $i++ ) { |
|
|
|
$results->{multiple_used_regex}->[$i]->{regex} = |
|
|
|
$multiple_used_regex[$i]; |
|
|
|
my @ids = join( ",", @{ $uniq_regexes{ $multiple_used_regex[$i] } } ); |
|
|
|
$results->{multiple_used_regex}->[$i]->{internal_ids} = \@ids; |
|
|
|
} |
|
|
|
return $results; |
|
|
|
} |
|
|
|
|
|
|
|
sub print_csv_statistics { |
|
|
|
my $self = shift; |
|
|
|
my $results = $self->_prepare_statistics(); |
|
|
|
my $version = $results->{filename}; |
|
|
|
$version =~ s/DROID_SignatureFile_V(\d+)\.xml/$1/; |
|
|
|
$results->{version} = $version; |
|
|
|
$results->{best_quality_puid} = $results->{nth_best_quality}->[0]->{puid}; |
|
|
|
$results->{best_quality_internal_id} = |
|
|
|
$results->{nth_best_quality}->[0]->{internal_id}; |
|
|
|
$results->{best_quality_quality} = |
|
|
|
$results->{nth_best_quality}->[0]->{quality}; |
|
|
|
$results->{best_quality_combined_regex} = |
|
|
|
$results->{nth_best_quality}->[0]->{combined_regex}; |
|
|
|
$results->{worst_quality_puid} = $results->{nth_worst_quality}->[0]->{puid}; |
|
|
|
$results->{worst_quality_internal_id} = |
|
|
|
$results->{nth_worst_quality}->[0]->{internal_id}; |
|
|
|
$results->{worst_quality_quality} = |
|
|
|
$results->{nth_worst_quality}->[0]->{quality}; |
|
|
|
$results->{worst_quality_combined_regex} = |
|
|
|
$results->{nth_worst_quality}->[0]->{combined_regex}; |
|
|
|
|
|
|
|
my @headers = |
|
|
|
qw(version filename count_of_puids count_of_internal_ids count_of_regular_expressions count_of_fileendings count_of_puid_with_fileendings_only count_of_orphaned_internal_ids count_of_multiple_used_regex best_quality_puid best_quality_internal_id best_quality_quality best_quality_combined_regex worst_quality_puid worst_quality_internal_id worst_quality_quality worst_quality_combined_regex); |
|
|
|
say "#", join( ",", @headers ); |
|
|
|
say join( |
|
|
|
",", |
|
|
|
map { |
|
|
|
my $result = $results->{$_}; |
|
|
|
if ( !defined $result ) { $result = ""; } |
|
|
|
$result; |
|
|
|
} @headers |
|
|
|
); |
|
|
|
} |
|
|
|
|
|
|
|
sub print_statistics { |
|
|
|
my $self = shift; |
|
|
|
my $verbose = shift; |
|
|
|
my $results = $self->_prepare_statistics(); |
|
|
|
|
|
|
|
say "Statistics of file $results->{filename}"; |
|
|
|
say "======================================="; |
|
|
|
say ""; |
|
|
|
say "Countings"; |
|
|
|
say "---------------------------------------"; |
|
|
|
say "Count of PUIDs: $results->{count_of_puids}"; |
|
|
|
say |
|
|
|
" internal IDs: $results->{count_of_internal_ids}"; |
|
|
|
say |
|
|
|
" regular expressions: $results->{count_of_regular_expressions}"; |
|
|
|
say |
|
|
|
" file endings: $results->{count_of_fileendings}"; |
|
|
|
say |
|
|
|
" PUIDs with file endings only: $results->{count_of_puid_with_fileendings_only}"; |
|
|
|
|
|
|
|
if ( defined $verbose ) { |
|
|
|
say " (", |
|
|
|
join( ",", @{ $results->{internal_ids_without_puids} } ), ")"; |
|
|
|
} |
|
|
|
say |
|
|
|
" orphaned internal IDs: $results->{count_of_orphaned_internal_ids}"; |
|
|
|
if ( defined $verbose ) { |
|
|
|
say " (", |
|
|
|
join( ",", @{ $results->{internal_ids_without_puids} } ), ")"; |
|
|
|
} |
|
|
|
say ""; |
|
|
|
say "Quality of internal IDs"; |
|
|
|
say "---------------------------------------"; |
|
|
|
|
|
|
|
my $nth = 1; |
|
|
|
foreach my $n ( @{ $results->{nth_best_quality} } ) { |
|
|
|
say |
|
|
|
"$nth-best quality internal ID (PUID, name): $n->{internal_id} ($n->{puid}, $n->{name}) -> $n->{quality}"; |
|
|
|
if ( defined $verbose ) { |
|
|
|
say " combined regex: ", $n->{combined_regex}; |
|
|
|
} |
|
|
|
$nth++; |
|
|
|
} |
|
|
|
say ""; |
|
|
|
$nth = 1; |
|
|
|
foreach my $n ( @{ $results->{nth_worst_quality} } ) { |
|
|
|
say |
|
|
|
"$nth-worst quality internal ID (PUID, name): $n->{internal_id} ($n->{puid}, $n->{name}) -> $n->{quality}"; |
|
|
|
if ( defined $verbose ) { |
|
|
|
say " combined regex: ", $n->{combined_regex}; |
|
|
|
} |
|
|
|
$nth++; |
|
|
|
} |
|
|
|
say ""; |
|
|
|
|
|
|
|
say ""; |
|
|
|
say "Regular expressions"; |
|
|
|
say "---------------------------------------"; |
|
|
|
say |
|
|
|
"Count of multiple used regular expressions: $results->{count_of_multiple_used_regex}"; |
|
|
|
if ( defined $verbose ) { |
|
|
|
for ( my $i = 0 ; $i < $results->{count_of_multiple_used_regex} ; $i++ ) |
|
|
|
{ |
|
|
|
say " common regex group no $i:"; |
|
|
|
say " regex='" |
|
|
|
. $results->{multiple_used_regex}->[$i]->{regex} . "'"; |
|
|
|
say " internal IDs: ", |
|
|
|
join( ",", |
|
|
|
@{ $results->{multiple_used_regex}->[$i]->{internal_ids} } ); |
|
|
|
} |
|
|
|
} |
|
|
|
say ""; |
|
|
|
|
|
|
|
#my @rx = $self->get_all_regular_expressions(); |
|
|
|
#use Data::Printer; |
|
|
|
#p( %uniq_regexes ); |
|
|
|
} |
|
|
|
|
|
|
|
1; |
|
|
|
|
|
|
|
no Moose; |
|
|
|
__PACKAGE__->meta->make_immutable; |
|
|
|
|
|
|
|
__END__ |
|
|
|
# Below is stub documentation for your module. You'd better edit it! |
|
|
|
|
|
|
|
=head1 NAME |
|
|
|
|
|
|
|
File::FormatIdentification::Pronom - Perl extension for parsing Pronom-Signatures using DROID-Signature file |
|
|
|
|
|
|
|
=head1 SYNOPSIS |
|
|
|
|
|
|
|
use File::FormatIdentification::Pronom; |
|
|
|
my $pronomfile = "Droid-Signature.xml"; |
|
|
|
my ( $signatures, $internals ) = parse_signaturefile($pronomfile); |
|
|
|
|
|
|
|
|
|
|
|
=head1 DESCRIPTION |
|
|
|
|
|
|
|
Stub documentation for File::FormatIdentification::Pronom, created by h2xs. It looks like the |
|
|
|
author of the extension was negligent enough to leave the stub |
|
|
|
unedited. |
|
|
|
|
|
|
|
Blah blah blah. |
|
|
|
|
|
|
|
=head2 EXPORT |
|
|
|
|
|
|
|
None by default. |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
=head1 SEE ALSO |
|
|
|
|
|
|
|
Mention other useful documentation such as the documentation of |
|
|
|
related modules or operating system documentation (such as man pages |
|
|
|
in UNIX), or any relevant external documentation such as RFCs or |
|
|
|
standards. |
|
|
|
|
|
|
|
If you have a mailing list set up for your module, mention it here. |
|
|
|
|
|
|
|
If you have a web site set up for your module, mention it here. |
|
|
|
|
|
|
|
=head1 AUTHOR |
|
|
|
|
|
|
|
art1, E<lt>art1@E<gt> |
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
|
|
|
|
|
|
|
Copyright (C) 2018 by art1 |
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
|
|
|
it under the same terms as Perl itself, either Perl version 5.24.1 or, |
|
|
|
at your option, any later version of Perl 5 you may have available. |
|
|
|
|
|
|
|
|
|
|
|
=cut |
