$ttl

\n} : qq{

\n};
  syswrite($ofh, $buf, length($buf));
  while (defined($buf = $ifh->getline))
  { $buf =~ s{&}{&}g;
    $buf =~ s{<}{<}g;
    $buf =~ s{>}{>}g;
    $buf =~ s{(https?://\S+)}{$1};
    syswrite($ofh, $buf, length($buf));
  }
  $buf = qq{

\n}; syswrite($ofh, $buf, length($buf)); $ifh->close; return; } # Insert a HTML file sub _cat_html { my ($ofh, $ifh) = @_; my ($lin); # Skip the head section for (;;) ## no critic (Loop) { return unless defined($lin = $ifh->getline); last if $lin =~ m/\/i; } # Transfer the HTML code $lin = qq{

\n}; for (;;) ## no critic (Loop) { syswrite($ofh, $lin, length($lin)); return unless defined($lin = $ifh->getline); $lin =~ s{\<\/body\>.*}{}i; } $ifh->close; return; } # Insert a RDA report sub _cat_report ## no critic (Complex) { my ($ofh, $slf, $ifh, $nam, $wdt) = @_; my ($buf, $flg, $mrk, $pre, $str); while (<$ifh>) { if (m/^\.I\s*'(.*)'(\s+(\d+))?$/) ## no critic (Unused) { $buf = q{}; $buf .= qq{\n} unless $flg++; ($pre, $mrk) = split(/\001/, $1, 2); if (defined($mrk)) { $buf .= q{\n}; } else { $buf .= q{\n}; } if (defined($3) && $3 > 1) { $buf .= qq{

} ._encode_prefix($slf, $pre) .q{	} ._encode_prefix($slf, $mrk) .q{	}._encode_block($slf, $ifh).qq{
} ._encode_prefix($slf, $pre) .q{	}._encode_block($slf, $ifh).qq{

\n}; $flg = 0; } } else { if ($flg) { $buf = qq{\n}; syswrite($ofh, $buf, length($buf)); $flg = 0; } if (m/^\.C(\s*(\d+))?$/) ## no critic (Unused) { $buf = _encode_columns($slf, $ifh, $wdt, $1); } elsif (m/^\.M\s*(\d+)\s*'(.*?)\|((.*?)\|)?(.*)'$/) ## no critic (Unused) { $buf = qq{\n} .q{\n} ._encode_table($slf, $ifh, $2, $4).qq{

} ._encode_prefix($slf, $pre).q{

} ._encode_string($slf, $5).qq{

\n}; } elsif (m/^\.M\s*\d+\s*'(.*)'$/) { if ($nam && $1 eq 'NAME') { $str = $nam; $str =~ s{[^A-Za-z\d\-\:\.]+}{_}g; $str =~ s{_$}{}; $str =~ s{^_}{}; $buf = qq{

$nam

\n}; } else { $buf = qq{

$1

\n}; } $buf .= qq{\n}._encode_table($slf, $ifh) .qq{

\n}; } elsif (m/^\.N(\s*\d+)?$/) ## no critic (Unused) { next; } elsif (m/^\.P(\s*\d+)?$/) ## no critic (Unused) { $buf = q{

}._encode_block($slf, $ifh).qq{

\n}; } elsif (m/^\.Q\s*(\w+)='(.*)'$/) { $buf = q{\n}; } elsif (m/^\.R\s*'(.*)'$/) { $buf = qq{

$1

\n}; } elsif (m/^\.S$/) { $buf = qq{

\n}; } elsif (m/^\.T\s*'(.*)'$/) { if ($nam && $1 eq 'NAME') { $str = $nam; $str =~ s{[^A-Za-z\d\-\:\.]+}{_}g; $str =~ s{_$}{}; $str =~ s{^_}{}; $buf = qq{

$nam

\n}; } else { $buf = qq{

$1

\n}; } } else { $buf = qq{

\n}; } } syswrite($ofh, $buf, length($buf)); } if ($flg) { $buf = qq{\n}; syswrite($ofh, $buf, length($buf)); } $ifh->close; return; } sub _encode_block { my ($slf, $ifh) = @_; local $/ = q{}; # Treat multiple empty lines as a single empty line my $lin = _encode_string($slf, $ifh->getline); $lin =~ s{\n}{
}g; return $lin; } sub _encode_columns { my ($slf, $ifh, $wdt, $sep) = @_; my ($buf, $cnt, $col, $lgt, $lin, $max, $pre, $txt, @tbl); $buf = q{}; $cnt = $max = 0; $sep = 0 unless defined($sep); while (defined($lin = $ifh->getline)) { last if $lin =~ m/^$/; ## no critic (Fixed) push(@tbl, $lin); $lin =~ s{\001}{}; $lin =~ s{\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})}{chr(oct($1))}eg; $max = $lgt if ($lgt = length($lin)) > $max; ++$cnt; } if ($max && ($col = int($wdt / ($max + $sep)))) { for (; $cnt % $col ; ++$cnt) ## no critic (Loop) { push(@tbl, q{}); } $lgt = $cnt / $col; } if ($col > 1) { $sep = q{ }x$sep; for (my $row = 0 ; $row < $lgt ; ++$row) ## no critic (Loop) { $buf .= qq{\n}; for (my $off = $row ; $off < $cnt ; $off += $lgt) ## no critic (Loop) { $txt = $tbl[$off]; $txt =~ s{\001}{}; $txt =~ s{\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})}{chr(oct($1))}eg; $buf .= qq{$sep} ._encode_string($slf, $txt).q{}; } $buf .= qq{\n}; } } else { foreach my $row (@tbl) { ($pre, $txt) = split(/\001/, $row, 2); $buf .= defined($txt) ? q{} ._encode_prefix($slf, $pre) .q{} ._encode_string($slf, $txt) .qq{\n} : q{}._encode_string($slf, $pre).qq{\n}; } } return $buf ? qq{$buf

} : q{}; } sub _encode_link { my ($slf, $typ, $lnk, $txt) = @_; my ($str); return exists($tb_typ{$typ}) ? q{$txt} : qq{$txt}; } sub _encode_prefix { my ($slf, $str) = @_; $str =~ s{\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})}{chr(oct($1))}eg; $str =~ s{\s}{\240}g; $str = _encode_style($slf, RDA::Driver::Sgml::encode($str, 1)); $str =~ s{^(( )*)[o\*\-](( )*)$}{$1·$3}; return $str; } sub _encode_string { my ($slf, $str) = @_; $str =~ s{[\n\r\s]+$}{}; $str =~ s{\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})}{chr(oct($1))}eg; return _encode_style($slf, RDA::Driver::Sgml::encode($str, 1)); } sub _encode_style { my ($slf, $str) = @_; $str =~ s{``(.*?)``}{$1}g; $str =~ s{~~(.*?)~~}{$1}g; $str =~ s{\*\*(.*?)\*\*}{$1}g; $str =~ s{!!(\w+):(.*?)!(.*?)!!}{_encode_link($slf, $1, $2, $3)}eg; return $str; } sub _encode_table { my ($slf, $ifh, $pre, $mrk) = @_; my ($buf, $lin); $buf = q{}; $pre = q{} unless defined($mrk); $pre =~ s{\S}{ }g; $mrk = q{ } unless defined($mrk); $pre = q{} ._encode_prefix($slf, $pre) .q{} ._encode_prefix($slf, $mrk) .q{}; while (defined($lin = $ifh->getline)) { last if $lin =~ m/^$/; ## no critic (Fixed) $buf .= $pre .join(q{ }, map {_encode_string($slf, $_)} split(/\|/, $lin)) .qq{\n}; } return $buf; } # Insert a string sub _cat_string { my ($ofh, $str, $ttl) = @_; my ($buf); $buf = defined($ttl) ? qq{

$ttl

\n$str\n} : qq{$str\n}; syswrite($ofh, $buf, length($buf)); return; } # Format anchors sub _fmt_anchor { my ($typ, $str) = @_; $str =~ s{[\\\/]}{::}g if $typ =~ m/^\#/; return $typ.encode_uri($str); } # Format links sub _fmt_link { my ($txt, $url, $pre) = @_; my ($typ); $url =~ s{::}{/}g; ($typ, $url) = split(/\//, $url, 2); return exists($tb_typ{$typ}) ? qq{\001a href='}.$pre._fmt_anchor($tb_typ{$typ}, $url) .qq{'\002$txt\001/a\002} : qq{\001code\002$txt\001/code\002} if defined($url); return exists($tb_lnk{$typ}) ? qq{\001a href='}.encode_uri($pre.$tb_lnk{$typ}).qq{'\002$txt\001/a\002} : qq{\001code\002$txt\001/code\002}; } # Get the manual page of a rule set sub _get_hcve_man { my ($slf, $set) = @_; my ($man, $pth, $tim, @sta); # Check for a file in cache if (exists($slf->{'_man'}->{$set})) { ($tim, $pth) = @{$slf->{'_man'}->{$set}}; return $pth if _get_hcve_time($slf, $set) < $tim && -f $pth; delete($slf->{'_man'}->{$set}); } # Check the existence of existing documentation if ($set =~ m/^([A-Z][A-Z\d]*):([A-Z])([A-Za-z\d]+)_(.*)$/) { $pth = RDA::Object::Rda->cat_file( $slf->{'_agt'}->get_collector->get_dir('C'), join(q{_}, uc($1), 'HCVE', uc($2), uc($3), $4, 'man.htm')); if (-f $pth && (@sta = stat($pth)) && _get_hcve_time($slf, $set) < $sta[9]) { $slf->{'_man'}->{$set} = [$sta[9], $pth]; return $pth; } } # Generate the rule set documentation return unless defined($man = $slf->{'_agt'}->submit(q{.}, 'DIAGLET.MAN', diaglet => $set, keep => 1)->get_first('man')); $slf->{'_man'}->{$set} = [$tim, $man]; return $man; } # Get the last modification date/time of a rule set sub _get_hcve_time { my ($slf, $set) = @_; my (@sta); @sta = stat($slf->{'_cfg'}->get_file('D_RDA_CHK', $set, '.xml')); return $sta[9] || 0; } # Parse the query string sub parse_query { my ($hsh, $qry) = @_; my ($cnt); if (defined($qry)) { foreach my $arg (split(/\&/, $qry)) { next unless $arg =~ m/^(\w+)=(.*)$/; $hsh->{$1} = $2; ++$cnt; } } return $cnt; } 1; __END__ =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L =head1 COPYRIGHT NOTICE Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved. =head1 TRADEMARK NOTICE Oracle and Java are registered trademarks of Oracle and/or its affiliates. Other names may be trademarks of their respective owners. =cut