$ttl

\n" : "

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

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

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

" ._encode_prefix($pr1) ."	" ._encode_prefix($pr2) ."	"._encode_block($ifh)."
" ._encode_prefix($pr1) ."	"._encode_block($ifh)."

\n"; $flg = 0; } } else { if ($flg) { $buf = "\n"; syswrite($ofh, $buf, length($buf)); $flg = 0; } if (m/^.C(\s*(\d+))?$/) { $buf = _encode_columns($ifh, $wdt, $2); } elsif (m/^.N\s*(\d+)$/) { next; } elsif (m/^.P(\s*(\d+))?$/) { $buf = "

"._encode_block($ifh)."

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

$1

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

\n"; } elsif (m/^.T\s*'(.*)'$/) { $buf = ($nam && $1 eq 'NAME') ? "

$nam

\n" : "

$1

\n"; } else { $buf = "

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

" : ''; } sub _encode_link { my ($typ, $lnk, $txt) = @_; exists($tb_typ{$typ}) ? "$txt" : "$txt"; } sub _encode_prefix { my ($str) = @_; $str =~ s/\\([0-7]{3}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg; $str =~ s/\s/\240/g; $str = _encode_style(RDA::Object::Sgml::encode($str)); $str =~ s/^(( )*)[o\*\-](( )*)$/$1·$3/; $str; } sub _encode_string { my ($str) = @_; $str =~ s/[\n\r\s]+$//; $str =~ s/\\([0-7]{3}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg; _encode_style(RDA::Object::Sgml::encode($str)); } sub _encode_style { my ($str) = @_; $str =~ s#``(.*?)``#$1#g; $str =~ s#~~(.*?)~~#$1#g; $str =~ s#\*\*(.*?)\*\*#$1#g; $str =~ s#\!\!(\w+):(.*?)\!(.*?)\!\!#_encode_link($1, $2, $3)#eg; $str; } # Format links sub _fmt_link { my ($txt, $url) = @_; my ($typ); $url =~ s#::#/#g; ($typ, $url) = split(/\//, $url, 2); return exists($tb_typ{$typ}) ? "\001a href='".$tb_typ{$typ}.$url."'\002$txt\001/a\002" : "\001code\002$txt\001/code\002" if defined($url); return exists($tb_lnk{$typ}) ? "\001a href='".$tb_lnk{$typ}."'\002$txt\001/a\002" : "\001code\002$txt\001/code\002"; } # Get the manual page of a rule set sub _get_hcve_man { my ($slf, $set) = @_; my ($cmd, $lin, $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 $pth = RDA::Object::Rda->cat_file($slf->{'_dir'}, $slf->{'_grp'}.'_HCVE_'.$set.'_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 $cmd = $slf->{'_agt'}->get_setting('RDA_SELF').' -T M:hcve:'.$set; $tim = time; ($lin) = grep {m/description file: (.*)/} `$cmd`; return unless $lin =~ m/description file: (.*)/; $slf->{'_man'}->{$set} = [$tim, $1]; return $1; } # 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_HCVE', $set, '.xml')); $sta[9] || 0; } # Get the title of a rule set sub _get_hcve_title { my ($slf, $set, $dft) = @_; my ($buf, $cnt, $pth, $ifh, $tim, $ttl); # Check for a title in cache if (exists($slf->{'_ttl'}->{$set})) { ($tim, $ttl) = @{$slf->{'_ttl'}->{$set}}; return $ttl if _get_hcve_time($slf, $set) < $tim; delete($slf->{'_ttl'}->{$set}); } # Extract the title $ifh = IO::File->new; $pth = $slf->{'_cfg'}->get_file('D_RDA_HCVE', $set, '.xml'); if ($ifh->open("<$pth")) { $buf = ''; $cnt = 10; while (<$ifh>) { $buf .= $_; $buf =~ s/[\n\r\s]*$/ /; if ($buf !~ m##) { $buf =~ s#.*close; $slf->{'_ttl'}->{$set} = [_get_hcve_time($slf, $set), $2]; return $2; } last } } $ifh->close; } # Return the default title $ttl; } # 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; } } $cnt; } 1; __END__ =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, L, L =head1 COPYRIGHT NOTICE Copyright (c) 2002, 2012, 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