Reorganize where the POD should be placed
The converter now only handles POD from the root DBD object. However there are commands that pull POD out of named sub-objects. This also adds generating tables from menu choices.
This commit is contained in:
Andrew Johnson
committed by
Ralph Lange
Ralph Lange
parent
f519b63a6f
commit
a05f022e44
@@ -1,6 +1,6 @@
|
||||
#!/usr/bin/perl
|
||||
#*************************************************************************
|
||||
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
|
||||
# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
|
||||
# National Laboratory.
|
||||
# EPICS BASE is distributed subject to a Software License Agreement found
|
||||
# in file LICENSE that is included with this distribution.
|
||||
@@ -8,6 +8,8 @@
|
||||
|
||||
# $Id$
|
||||
|
||||
use strict;
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../lib/perl";
|
||||
|
||||
@@ -19,6 +21,8 @@ use EPICS::Readfile;
|
||||
use Pod::Simple::HTML;
|
||||
|
||||
my $tool = 'dbdToHtml';
|
||||
|
||||
use vars qw($opt_D @opt_I $opt_o);
|
||||
getopts('DI@o:') or
|
||||
die "Usage: $tool [-D] [-I dir] [-o file.html] file.dbd\n";
|
||||
|
||||
@@ -44,39 +48,31 @@ if ($opt_D) { # Output dependencies only
|
||||
exit 0;
|
||||
}
|
||||
|
||||
open my $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
|
||||
open my $out, '>', $opt_o or
|
||||
die "Can't create $opt_o: $!\n";
|
||||
|
||||
# Grab the Pod text from the root DBD object
|
||||
my @pod = $dbd->pod;
|
||||
|
||||
my $rtypes = $dbd->recordtypes;
|
||||
|
||||
# Append the processed Pod text from any record types defined
|
||||
while (my ($rn, $rtyp) = each %{$rtypes}) {
|
||||
foreach my $_ ($rtyp->pod) {
|
||||
# Handle our 'fields' Pod directive
|
||||
if (m/^=fields (.*)/) {
|
||||
my @names = split /\s*,\s*/, $1;
|
||||
# Look up every named field
|
||||
my @fields = map {
|
||||
my $field = $rtyp->field($_);
|
||||
print STDERR "Unknown field name '$_' in $infile POD\n" unless $field;
|
||||
$field;
|
||||
} @names;
|
||||
my $html;
|
||||
# Generate a HTML table row for each field
|
||||
foreach $field (@fields) {
|
||||
$html .= $field->htmlTableRow if $field;
|
||||
}
|
||||
# Add the complete table
|
||||
push @pod, podTable($html);
|
||||
}
|
||||
else {
|
||||
# Add other Pod text
|
||||
push @pod, $_;
|
||||
}
|
||||
# Parse the Pod text from the root DBD object
|
||||
my @pod = map {
|
||||
# Handle a 'recordtype' Pod directive
|
||||
if (m/^ =recordtype \s+ (.*)/x) {
|
||||
my $rn = $1;
|
||||
my $rtyp = $dbd->recordtype($rn);
|
||||
die "Unknown recordtype '$rn' in $infile POD directive\n"
|
||||
unless $rtyp;
|
||||
rtypeToPod($rtyp, $dbd);
|
||||
}
|
||||
}
|
||||
# Handle a 'menu' Pod directive
|
||||
elsif (m/^ =menu \s+ (.*)/x) {
|
||||
my $mn = $1;
|
||||
my $menu = $dbd->menu($mn);
|
||||
die "Unknown menu '$mn' in $infile POD directive\n"
|
||||
unless $menu;
|
||||
menuToPod($menu);
|
||||
}
|
||||
else {
|
||||
$_;
|
||||
}
|
||||
} $dbd->pod;
|
||||
|
||||
my $podHtml = Pod::Simple::HTML->new();
|
||||
$podHtml->html_css('style.css');
|
||||
@@ -90,18 +86,70 @@ print $out $html;
|
||||
close $out;
|
||||
|
||||
|
||||
sub podTable {
|
||||
my $content = shift;
|
||||
return ("=begin html\n", "\n",
|
||||
sub menuToPod {
|
||||
my ($menu) = @_;
|
||||
my $index = 0;
|
||||
return "=begin html\n", "\n",
|
||||
"<blockquote><table border =\"1\"><tr>\n",
|
||||
"<th>Field</th><th>Summary</th><th>Type</th><th>DCT</th>",
|
||||
"<th>Default</th><th>Read</th><th>Write</th><th>CA PP</th></tr>\n",
|
||||
$content, "</table></blockquote>\n",
|
||||
"\n", "=end html\n");
|
||||
"<th>Index</th><th>Identifier</th><th>Choice String</th>\n",
|
||||
"</tr>\n",
|
||||
map({choiceTableRow($_, $index++)} $menu->choices),
|
||||
"</table></blockquote>\n",
|
||||
"\n", "=end html\n";
|
||||
}
|
||||
|
||||
sub DBD::Recfield::htmlTableRow {
|
||||
my $fld = shift;
|
||||
sub choiceTableRow {
|
||||
my ($ch, $index) = @_;
|
||||
my ($id, $name) = @{$ch};
|
||||
return '<tr><td class="cell">',
|
||||
$index,
|
||||
'</td><td class="cell">',
|
||||
$id,
|
||||
'</td><td class="cell">',
|
||||
$name,
|
||||
"</td></tr>\n";
|
||||
}
|
||||
|
||||
sub rtypeToPod {
|
||||
my ($rtyp, $dbd) = @_;
|
||||
return map {
|
||||
# Handle a 'fields' Pod directive
|
||||
if (m/^ =fields \s+ (.*)/x) {
|
||||
my @names = split /\s*,\s*/, $1;
|
||||
# Look up the named fields
|
||||
my @fields = map {
|
||||
my $field = $rtyp->field($_);
|
||||
die "Unknown field name '$_' in $infile POD\n"
|
||||
unless $field;
|
||||
$field;
|
||||
} @names;
|
||||
# Generate Pod for the table
|
||||
"=begin html\n", "\n",
|
||||
"<blockquote><table border =\"1\"><tr>\n",
|
||||
"<th>Field</th><th>Summary</th><th>Type</th><th>DCT</th>",
|
||||
"<th>Default</th><th>Read</th><th>Write</th><th>CA PP</th>",
|
||||
"</tr>\n",
|
||||
map({fieldTableRow($_, $dbd)} @fields),
|
||||
"</table></blockquote>\n",
|
||||
"\n", "=end html\n";
|
||||
}
|
||||
# Handle a 'menu' Pod directive
|
||||
elsif (m/^ =menu \s+ (.*)/x) {
|
||||
my $mn = $1;
|
||||
my $menu = $dbd->menu($mn);
|
||||
die "Unknown menu '$mn' in $infile POD directive\n"
|
||||
unless $menu;
|
||||
menuToPod($menu);
|
||||
}
|
||||
else {
|
||||
# Raw text line
|
||||
$_;
|
||||
}
|
||||
} $rtyp->pod;
|
||||
}
|
||||
|
||||
sub fieldTableRow {
|
||||
my ($fld, $dbd) = @_;
|
||||
my $html = '<tr><td class="cell">';
|
||||
$html .= $fld->name;
|
||||
$html .= '</td><td class="cell">';
|
||||
@@ -111,8 +159,12 @@ sub DBD::Recfield::htmlTableRow {
|
||||
$html .= $type;
|
||||
$html .= ' [' . $fld->attribute('size') . ']'
|
||||
if $type eq 'STRING';
|
||||
$html .= ' (' . $fld->attribute('menu') . ')'
|
||||
if $type eq 'MENU';
|
||||
if ($type eq 'MENU') {
|
||||
my $mn = $fld->attribute('menu');
|
||||
my $menu = $dbd->menu($mn);
|
||||
my $url = $menu ? "#Menu_$mn" : "${mn}.html";
|
||||
$html .= " (<a href='$url'>$mn</a>)";
|
||||
}
|
||||
$html .= '</td><td class="cell">';
|
||||
$html .= $fld->attribute('promptgroup') ? 'Yes' : 'No';
|
||||
$html .= '</td><td class="cell">';
|
||||
|
||||
Reference in New Issue
Block a user