} .q{

}.get_string('TtlCN') .qq{

}.get_string('CN') .qq{

}.get_string('TtlTN') .qq{

}.get_string('TN') .qq{

}.get_string('TtlLN') .qq{

}.get_string('LN') .qq{

}.get_string('TtlAN') .qq{

}.get_string('AN1') .qq{

}.get_string('AN2') .q{ }.get_string('AN3') .qq{

}.get_string('AN4') .q{ }.get_string('AN5') .q{

}; my $TOP = qq{

\n}; ## use critic # Define acronyms my $RDA = q{RDA}; my %ABR = ( CFM => q{CFM}, HCVE => q{HCVE}, IRDA => q{IRDA}, OCM => q{OCM}, RDA => $RDA, SDCI => q{SDCI}, SDCL => q{SDCL}, SDSL => q{SDSL}, ); my $ABR = join(q{|}, keys(%ABR)); # Define the global private variables my @tb_bit = qw( --- --x -w- -wx r-- r-x rw- rwx --S --s -wS -ws r-S r-s rwS rws); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Driver::Web-Enew($cfg)> The object constructor. It takes a reference to RDA software configuration as an argument. C is represented by a blessed hash reference. The following special keys are used: =over 12 =item S< B<'oid' > > Object identifier =item S< B<'_reg'> > Applicable regions =item S< B<'_ver'> > RDA software version =item S< B<'_wdt'> > Page width parameter =back Internal keys are prefixed by an underscore. =cut sub new { my ($cls, $cfg) = @_; my ($slf, $val); # Create the render object $slf = bless { oid => 'WEB', _reg => {text => 1}, _ver => $cfg->get_version, _wdt => $cfg->get_columns, }, ref($cls) || $cls; # Identify applicable regions if (defined($val = $cfg->get_env('RDA_MAN'))) { foreach my $key (split(/,/, $val)) { $slf->{'_reg'}->{$key} = 1 if $key; } } # Return the object reference return $slf; } =head2 S<$h-Epod($ofh,$name,$file[,$fct[,$pre]])> This method extracts the Plain Old Documentation (POD) from the specified file and converts it into HTML. You can specify a function to convert the links as an extra argument. =cut sub pod ## no critic (Complex) { my ($slf, $ofh, $nam, $fil, $fct, $pre) = @_; my ($cut, $flg, $ifh, $max, $nwl, $off, $reg, $str, $tag, @tbl); local $/ = q{}; # Treat multiple empty lines as a single empty line $cut = $off = 2; $fct = \&_fmt_link unless defined($fct); $flg = 0; $nwl = q{}; $tag = [0, q{

}, qq{

\n}, q{

}, qq{

\n}]; # Extract the documentation and format it if (ref($fil)) { $ifh = $fil; } else { $ifh = IO::File->new; $ifh->open("<$fil") or die get_string('ERR_OPEN', $fil, $!); } while (<$ifh>) { # Extract the documentation if ($cut) { next unless m/^=/; $cut = 0; } if ($reg) { next unless m/^=end\s+$reg[\n\r\s]*$/; $reg = undef; } # Resolve attributes $max = 10; s{\&}{\&}g; s{E<(\d+)>}{\&\#$1;}g; s{E<(\w+)>}{\&$1;}g; s{^(\s*)((?:<|require |use |(?:rda|sdci|sdp)\.\w+ ).*)$} {qq{$1\001code\002}._fmt_preformed($2).qq{\001/code\002}}sge; s{B<(\s*)>}{$1}sg; s{^(=item(?:\s+o)?\s+S<\s*B<\s*)($LNK|[^<>]*?)\s*>\s*>\s*(\S.*)} {$1$2>>\003$3}s || s{^(=item(?:\s+o)?\s+B<\s*)($LNK|[^<>]*?)\s*>\s*(\S.*)} {$1$2>\003$3}s; while ($max-- && /[A-Z]]+)\|([^>]+)>}{&{$fct}(_fmt_lnk($1), $2, $pre)}sge; s{B<(.*?)>}{qq{\001strong\002\001tt\002}._fmt_space($1, 1). qq{\001/tt\002\001/strong\002}}sge; s{[CF]<(.*?)>}{qq{\001code\002}._fmt_space($1).qq{\001/code\002}}sge; s{I<(.*?)>}{\001em\002$1\001/em\002}sg; s{S<(.*?)>}{_fmt_space($1)}sge; s{X<.*?>}{}sg; s{[A-Z]<(.*?)>}{$1}sg; } s{<}{<}g; s{>}{>}g; s{\001}{<}g; s{\002}{>}g; s{[\s\r\n]+$}{}; # Treat the pod directives if (s/^=(\S*)\s?//) { my $cmd = $1; $nwl = q{}; if ($cmd eq 'cut') { $cut = 1; } elsif ($cmd eq 'pod') { $cut = 0; } elsif ($cmd eq 'head1') { if (m/(?:COPYRIGHT|TRADEMARK) NOTICE/) { $cut = 1; } elsif ($_ eq 'NAME') { $str = _fmt_name($nam); _prt_str($ofh, qq{

}._fmt_abbr($nam).qq{

\n}); } else { _prt_str($ofh, qq{

$_

\n}); } } elsif ($cmd eq 'head2') { _prt_str($ofh, qq{

$_

\n}); } elsif ($cmd eq 'head3') { _prt_str($ofh, qq{

$_

\n}); } elsif ($cmd eq 'over') { unshift(@tbl, $tag); _prt_str($ofh, qq{\n\n

\n}); $tag = [1, qq{ \n}, q{}, qq{
}, qq{	}, q{}]; $flg = 1; $off = 5; } elsif ($cmd eq 'back') { if ($tag = shift(@tbl)) { _prt_str($ofh, qq{

\n}); } else { $tag = [0, q{

}, qq{

\n}, q{

}, qq{

\n}]; } $flg = $tag->[0]; $off = 3; } elsif ($cmd eq 'item') { s/^(\s*)[o\*](?:\s|\z)/$1·\003/; s/\003/$tag->[4]/g; _prt_str($ofh, $tag->[$off].$_.$tag->[4]); $off = 3; $flg = 1; } elsif ($cmd eq 'begin') { if (!exists($slf->{'_reg'}->{$_})) { $reg = $_; } elsif ($_ eq 'credits') { _prt_str($ofh, qq{

CREDITS

\n}); } } } elsif (m/^\s+/) { ($flg, $str) = ($flg < 0) ? ($flg, $tag->[1]) : (-$flg, q{}); s{\n}{
}g; _prt_str($ofh, $nwl.$str.q{}._fmt_space($_).qq{
\n}); $nwl = q{
}; } else { ($flg, $str) = ($flg > 0) ? (-$flg, q{}) : ($flg, $tag->[1]); _prt_str($ofh, $str.$_.$tag->[2]); $nwl = q{}; } } while ($tag = shift(@tbl)) { _prt_str($ofh, qq{\n}); } $ifh->close; return; } sub _fmt_lnk { my ($str) = @_; $str =~ s/:/./g if $str =~ s/^abr://; return $str; } sub _prt_str { my ($ofh, $str) = @_; syswrite($ofh, $str, length($str)); return; } =head2 S<$h-Erender($ofh,$def)> This method converts the specified documentation in the POD format into HTML. The definition hash can contain the following keys: =over 11 =item B< 'css' > Style definition =item B< 'det' > List of files to render =item B< 'dsp' > Display format indicator =item B< 'fct' > Function to format links =item B< 'nam' > Page name =item B< 'not' > Specific page notice =item B< 'pre' > URL prefix =item B< 'rel' > List of related links =item B< 'tab' > List of main links =item B< 'ttl' > Page title =back A link item is represented by a scalar, used as text, or by an array reference containing the text and URL. =cut sub render { my ($slf, $ofh, $def) = @_; my ($buf, $col, $fct, $nam, $pre, $tbl, $ttl, $val, @arg); # Initialization $fct = $def->{'fct'} || \&_fmt_link; $pre = $def->{'pre'} || q{}; $nam = _fmt_name($def->{'nam'} || q{}); $ttl = $def->{'ttl'} || get_string('Title'); # Start the page unless ($def->{'dsp'}) { $buf = $BEG .(defined($def->{'css'}) ? $def->{'css'} : $CSS) .qq{$ttl\n}.$TOP .qq{

$RDA }.$slf->{'_ver'}.qq{ - $ttl

\n}; syswrite($ofh, $buf, length($buf)); } # Add the tab section if (ref($tbl = $def->{'tab'}) eq 'ARRAY' && ($col = scalar @{$tbl})) { $buf = q{

\n} .qq{\n}; $val = int(100 / $col); foreach my $det (@{$tbl}) { if (!ref($det)) { $buf .= qq{\n}; } elsif ($det->[2] eq $nam) { $buf .= qq{\n}; } else { $buf .= qq{\n}; } } $buf .= qq{

}.get_string('Main', $RDA) .qq{
} ._fmt_abbr($det).qq{	} ._fmt_abbr($det->[0]).qq{	} ._fmt_abbr($det->[0]).qq{

\n}; syswrite($ofh, $buf, length($buf)); } # Add the related link section if (ref($tbl = $def->{'rel'}) eq 'ARRAY') { $buf = q{

}.get_string('Related').qq{

\n} ._rel2html($tbl, $nam, $pre); syswrite($ofh, $buf, length($buf)); } # Add the page content foreach my $det (@{$def->{'det'}}) { if (ref($nam = $det->[0]) eq 'CODE') { (undef, @arg) = @{$det}; &$nam($ofh, @arg); } else { pod($slf, $ofh, $nam, $det->[1], $fct, $pre); } } # Terminate the page with all notices unless ($def->{'dsp'}) { $buf = (defined($def->{'not'}) ? $def->{'not'} : $NOT).$END; syswrite($ofh, $buf, length($buf)); } return; } sub _rel2html { my ($tbl, $nam, $pre) = @_; my ($buf); $buf = qq{\n}; foreach my $det (@{$tbl}) { if (ref($det)) { $buf .= q{\n}; } else { $buf .= q{\n}; } } $buf .= qq{

}._idx2html($det, $nam, $pre).qq{

}._fmt_abbr($det).qq{

\n}; return $buf; } sub _idx2html { my ($tbl, $nam, $pre) = @_; my ($buf); $buf = qq{

}._fmt_abbr($det).qq{
}._fmt_abbr($det->[0])._idx2html($det->[1], $nam, $pre) .qq{
} ._fmt_abbr($det->[0]).qq{

\n}; return $buf; } # Document abbreviations and acronyms sub _fmt_abbr { my ($txt) = @_; $txt =~ s{\b($ABR)\b}{$ABR{$1}}egs; return $txt; } # Generate a link sub _fmt_link { return shift; } # Generate an anchor sub _fmt_name { my ($str) = @_; $str =~ s{^.*\s-\s+}{}; $str =~ s{\.\w+$}{}; $str =~ s{\.[\/\\]}{}; $str =~ s{[\/\\]}{::}g; $str =~ s{[_\s]+}{_}g; return $str; } # Replace the spaces by non blanking spaces in preformed strings sub _fmt_preformed { my ($str, $flg) = @_; $str =~ s{'}{}g if $flg; $str =~ s{^(\s+)}{" " x length($1)}e; $str =~ s{\\\n\040+}{}gm; $str =~ s{\n\040+}{ }gm; $str =~ s{\s+}{ }g; $str =~ s{a href=}{a href=}g; return $str; } # Replace the spaces by non blanking spaces sub _fmt_space { my ($str, $flg) = @_; $str =~ s{'}{}g if $flg; $str =~ s{\s}{ }g; $str =~ s{a href=}{a href=}g; return $str; } # --- Formatting routines ----------------------------------------------------- # Decode an URI sub decode_uri { my ($str) = @_; if (defined($str)) { $str =~ s/\+/ /g; $str =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg; } return $str; } # Encode an URI sub encode_uri { my ($str); $str = join (q{/}, @_); $str =~ s/([^\w\-\.\!\~\*\:\/])/sprintf('%%%02x', ord($1))/ge; return $str; } # Format permissions sub fmt_bits { my ($val, $flg) = @_; $val += 8 if $flg; return $tb_bit[$val]; } # Format a date sub fmt_date { my ($str) = @_; return q{} unless $str; $str = gmtime($str); return q{ }.substr($str, 4, 12).q{ }.substr($str, 20, 4); } # Format the file mode sub fmt_mode { my ($mod) = @_; ## no critic (Bit,Number,Zero) return substr("Lpc?d?b?-?l?s?w?", ($mod >> 12) & 017, 1) .fmt_bits(($mod >> 6) & 07, $mod & 04000) .fmt_bits(($mod >> 3) & 07, $mod & 02000) .fmt_bits($mod & 07, $mod & 01000); ## use critic } 1; __END__ =head1 SEE ALSO 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