486 lines
15 KiB
Perl
486 lines
15 KiB
Perl
#!/usr/bin/env perl
|
|
#*************************************************************************
|
|
# Copyright (c) 2022 UChicago Argonne LLC, as Operator of Argonne
|
|
# National Laboratory.
|
|
# SPDX-License-Identifier: EPICS
|
|
# EPICS BASE is distributed subject to a Software License Agreement found
|
|
# in file LICENSE that is included with this distribution.
|
|
#*************************************************************************
|
|
|
|
#######################################################################
|
|
#
|
|
# capr: A program that attempts to do a "dbpr" command via channel
|
|
# access.
|
|
#
|
|
#######################################################################
|
|
|
|
use 5.10.1;
|
|
use strict;
|
|
|
|
use FindBin qw($RealBin);
|
|
use lib ("$RealBin/../../lib/perl");
|
|
|
|
use Getopt::Std;
|
|
use Cwd 'abs_path';
|
|
use CA;
|
|
|
|
######### Globals ##########
|
|
|
|
our ($opt_h, $opt_f, $opt_l, $opt_r, $opt_D);
|
|
our $opt_d = $ENV{EPICS_CAPR_DBD_FILE} // abs_path("$RealBin/../../dbd/softIoc.dbd");
|
|
our $opt_w = 2;
|
|
our $opt_n = 10;
|
|
|
|
my %record = (); # Empty hash to put dbd data in
|
|
|
|
# EPICS field types
|
|
my %fieldType = (
|
|
DBF_CHAR => 'DBF_CHAR',
|
|
DBF_UCHAR => 'DBF_CHAR',
|
|
DBF_DOUBLE => 'DBF_FLOAT',
|
|
DBF_FLOAT => 'DBF_FLOAT',
|
|
DBF_LONG => 'DBF_LONG',
|
|
DBF_INT64 => 'DBF_FLOAT',
|
|
DBF_SHORT => 'DBF_LONG',
|
|
DBF_ULONG => 'DBF_LONG',
|
|
DBF_USHORT => 'DBF_LONG',
|
|
DBF_UINT64 => 'DBF_FLOAT',
|
|
DBF_DEVICE => 'DBF_STRING',
|
|
DBF_ENUM => 'DBF_STRING',
|
|
DBF_FWDLINK => 'DBF_STRING',
|
|
DBF_INLINK => 'DBF_STRING',
|
|
DBF_MENU => 'DBF_STRING',
|
|
DBF_OUTLINK => 'DBF_STRING',
|
|
DBF_STRING => 'DBF_STRING',
|
|
DBF_NOACCESS => 'DBF_NOACCESS',
|
|
);
|
|
|
|
# globals for sub caget
|
|
my %connected;
|
|
my $unconnected_count;
|
|
my %callback_data;
|
|
my $callback_incomplete;
|
|
|
|
######### Main program ############
|
|
|
|
HELP_MESSAGE() unless getopts('hDd:f:l:n:rw:');
|
|
HELP_MESSAGE() if $opt_h;
|
|
|
|
die "File $opt_d not found. (\"capr.pl -h\" gives help)\n"
|
|
unless -f $opt_d;
|
|
|
|
parseDbd($opt_d);
|
|
print "Using $opt_d\n\n";
|
|
|
|
# Print a list of record types
|
|
if ($opt_r) {
|
|
print ("Record types found:\n");
|
|
printList($opt_l);
|
|
exit;
|
|
}
|
|
|
|
# Print the fields defined for given record
|
|
if ($opt_f) {
|
|
printRecordList($opt_f);
|
|
exit;
|
|
}
|
|
|
|
HELP_MESSAGE() unless @ARGV;
|
|
|
|
$_ = shift;
|
|
if (@ARGV) {
|
|
# Drop any ".FIELD" part
|
|
s/\. \w+ $//x;
|
|
printRecord($_, @ARGV);
|
|
} else {
|
|
if (m/^ \s* ([]+:;<>0-9A-Za-z[-]+) (?:\. \w+)? \s* , \s* (\d+) \s* $/x) {
|
|
# Recognizes ",n" as an interest level, drops any ".FIELD" part
|
|
printRecord($1, $2);
|
|
} else {
|
|
# Drop any ".FIELD" part
|
|
s/\. \w+ $//x;
|
|
printRecord($_, $opt_l);
|
|
}
|
|
}
|
|
|
|
########## End of main ###########
|
|
|
|
|
|
|
|
# parseDbd
|
|
# Takes given dbd file and parses it to produce a hash table of record types
|
|
# giving their fields, and for each field its interest level and data type.
|
|
# usage: parseDbd("fileName");
|
|
# Output goes to the global %record, a hash of references to other hashes
|
|
# containing the fields of each record type. Those hash values (keyed by
|
|
# field name) are references to arrays containing the interest level, data
|
|
# type and number base of the field.
|
|
sub parseDbd {
|
|
my $dbdFile = shift;
|
|
|
|
open(DBD, "< $dbdFile") or die "Can't open file $dbdFile: $!\n";
|
|
my @dbd = <DBD>;
|
|
close(DBD) or die "Can't close $dbdFile: $!\n";
|
|
|
|
my $i = 1;
|
|
my $level = 0;
|
|
my $isArecord = 0;
|
|
my $isAfield = 0;
|
|
my $thisRecord;
|
|
my $thisField;
|
|
my $thisType;
|
|
my $thisSize = 0;
|
|
my $field = {};
|
|
my $interest = 0;
|
|
my $thisBase = 'DECIMAL';
|
|
my $special = '';
|
|
|
|
while (@dbd) {
|
|
$_ = shift @dbd;
|
|
chomp;
|
|
if ( m/recordtype \s* \( \s* (\w+) \)/x ) {
|
|
die "File format error at line $i of file\n $opt_d\n"
|
|
unless $level == 0;
|
|
$isArecord = 1;
|
|
$thisRecord = $1;
|
|
}
|
|
elsif ( m/field \s* \( \s* (\w+) \s* , \s* (\w+) \s* \)/x ) {
|
|
die "File format error at line $i of file\n $opt_d\n"
|
|
unless $level == 1 && $isArecord;
|
|
$thisField = $1;
|
|
$thisType = $2;
|
|
$isAfield = 1;
|
|
$thisSize = 1024 if $thisType =~ m/^ DBF_(IN|OUT|FWD)LINK $/x;
|
|
}
|
|
elsif ( m/interest \s* \( \s* (\w+) \s* \)/x ) {
|
|
die "File format error at line $i of file\n $opt_d\n"
|
|
unless $level == 2 && $isAfield;
|
|
$interest = $1;
|
|
}
|
|
elsif ( m/size \s* \( \s* ([0-9]+) \s* \)/x ) {
|
|
die "File format error at line $i of file\n $opt_d\n"
|
|
unless $level == 2 && $isAfield;
|
|
$thisSize = $1;
|
|
}
|
|
elsif ( m/special \s* \( \s* (\w+) \s* \)/x ) {
|
|
die "File format error at line $i of file\n $opt_d\n"
|
|
unless $level == 2 && $isAfield;
|
|
$special = $1;
|
|
}
|
|
elsif ( m/base \s* \( \s* (\w+) \s* \)/x ) {
|
|
die "File format error at line $i of file\n $opt_d\n"
|
|
unless $level == 2 && $isAfield;
|
|
$thisBase = $1;
|
|
}
|
|
if ( m/\{/ ) {
|
|
$level++;
|
|
}
|
|
if ( m/\}/ ) {
|
|
if ($level == 2 && $isAfield) {
|
|
my $params = {};
|
|
$params->{interest} = $interest;
|
|
$params->{dbfType} = $thisType;
|
|
$params->{base} = $thisBase;
|
|
$params->{special} = $special;
|
|
$params->{size} = $thisSize;
|
|
$field->{$thisField} = $params;
|
|
|
|
# Reset default values
|
|
$isAfield = 0;
|
|
$interest = 0;
|
|
$thisBase = 'DECIMAL';
|
|
$special = '';
|
|
$thisSize = 0;
|
|
}
|
|
elsif ($level == 1 && $isArecord) {
|
|
$isArecord = 0;
|
|
$record{$thisRecord} = $field;
|
|
$field = {}; # start another hash
|
|
}
|
|
$level--;
|
|
}
|
|
$i++;
|
|
}
|
|
}
|
|
|
|
|
|
# Given a record name, attempts to find the record and its type.
|
|
# Usage: $recordType = getRecType("recordName");
|
|
sub getRecType {
|
|
my $arg = shift;
|
|
my $name = "$arg.RTYP";
|
|
|
|
my $fields_read = caget($name);
|
|
|
|
die "Could not determine record type of $arg\n"
|
|
unless $fields_read == 1;
|
|
|
|
return $callback_data{$name};
|
|
}
|
|
|
|
# Given the record type and field, returns the interest level, data type
|
|
# and number base for the field
|
|
# Usage: ($dataType, $interest, $base, $special, $size) = getFieldParams($recType, $field);
|
|
sub getFieldParams {
|
|
my ($recType, $field) = @_;
|
|
|
|
my $params = $record{$recType}{$field} or
|
|
die "Can't find params for $recType.$field";
|
|
exists($fieldType{$params->{dbfType}}) ||
|
|
die "Field data type $field for $recType not found in dbd file --";
|
|
exists($params->{interest}) ||
|
|
die "Interest level for $field in $recType not found in dbd file --";
|
|
|
|
my $fType = $fieldType{$params->{dbfType}};
|
|
my $fInterest = $params->{interest};
|
|
my $fBase = $params->{base};
|
|
my $fSpecial = $params->{special};
|
|
my $fSize = $params->{size};
|
|
return ($fType, $fInterest, $fBase, $fSpecial, $fSize);
|
|
}
|
|
|
|
# Prints field name and data for given field. Formats output so
|
|
# that fields align in to 4 columns. Tries to imitate dbpf format
|
|
# Usage: printField( $fieldName, $data, $dataType, $base, $firstColumnPosn)
|
|
sub printField {
|
|
my ($fieldName, $fieldData, $dataType, $base, $col) = @_;
|
|
|
|
my $screenWidth = 80;
|
|
my ($outStr, $wide);
|
|
|
|
|
|
if (ref $fieldData eq 'ARRAY') {
|
|
my $elems = scalar @{$fieldData};
|
|
my $field = "$fieldName\[$elems\]:";
|
|
my $count = $elems > $opt_n ? $opt_n : $elems;
|
|
my @show = @{$fieldData}[0 .. $count - 1];
|
|
$outStr = sprintf('%-5s %s', $field, join(', ', @show));
|
|
$outStr .= ", ..." if $elems > $count;
|
|
}
|
|
else {
|
|
my $field = "$fieldName:";
|
|
if ( $dataType eq 'DBF_STRING' ) {
|
|
$outStr = sprintf('%-5s %s', $field, $fieldData);
|
|
} elsif ( $base eq 'HEX' ) {
|
|
my $val = ( $dataType eq 'DBF_CHAR' ) ? ord($fieldData) : $fieldData;
|
|
$outStr = sprintf('%-5s 0x%x', $field, $val);
|
|
} elsif ( $dataType eq 'DBF_DOUBLE' || $dataType eq 'DBF_FLOAT' ) {
|
|
$outStr = sprintf('%-5s %.8f', $field, $fieldData);
|
|
} elsif ( $dataType eq 'DBF_UCHAR' ) {
|
|
$outStr = sprintf('%-5s %d', $field, ord($fieldData));
|
|
} else {
|
|
# DBF_INT64, DBF_LONG, DBF_SHORT,
|
|
# DBF_UINT64, DBF_ULONG, DBF_USHORT, DBF_UCHAR,
|
|
$outStr = sprintf('%-5s %d', $field, $fieldData);
|
|
}
|
|
}
|
|
|
|
my $len = length($outStr);
|
|
if ($len < 20) { $wide = 20; }
|
|
elsif ( $len < 40 ) { $wide = 40; }
|
|
elsif ( $len < 60 ) { $wide = 60; }
|
|
else { $wide = 80;}
|
|
|
|
my $pad = $wide - $len;
|
|
|
|
$col += $wide;
|
|
if ($col > $screenWidth ) {
|
|
print("\n");
|
|
$col = $wide;
|
|
}
|
|
|
|
print $outStr, ' ' x $pad;
|
|
|
|
return $col;
|
|
}
|
|
|
|
# Query the native values of a list of PVs simultaneously.
|
|
# The data is returned in the the %callback_data global hash.
|
|
# The return value is the number of read pvs
|
|
#
|
|
# NOTE: Not re-entrant because results are written to global hash
|
|
# %callback_data
|
|
#
|
|
# Usage: $fields_read = caget( @pvlist )
|
|
sub caget {
|
|
#clear any previous results;
|
|
%connected = ();
|
|
$unconnected_count = scalar @_;
|
|
%callback_data = ();
|
|
$callback_incomplete = 0;
|
|
|
|
my @chans = map {
|
|
print " Creating channel for $_\n" if $opt_D;
|
|
CA->new($_, \&canew_callback);
|
|
} @_;
|
|
my $channel_count = scalar @chans;
|
|
return 0 unless $channel_count gt 0;
|
|
|
|
print " $channel_count channels created.\n" if $opt_D;
|
|
|
|
my $elapsed = 0;
|
|
do {
|
|
print " Waiting for $unconnected_count channels to connect\n"
|
|
if $unconnected_count && $opt_D;
|
|
print " Waiting for data from $callback_incomplete channels\n"
|
|
if $callback_incomplete && $opt_D;
|
|
CA->pend_event(0.1);
|
|
$elapsed += 0.1;
|
|
} until (($elapsed > $opt_w) or
|
|
(scalar %connected && $callback_incomplete == 0));
|
|
my $data_count = scalar keys %callback_data;
|
|
printf " Got data from %d of %d channels\n", $data_count, $channel_count
|
|
if $opt_D;
|
|
return $data_count;
|
|
}
|
|
|
|
sub canew_callback {
|
|
my ($chan, $up) = @_;
|
|
return unless $up;
|
|
$connected{$chan->name} = $chan;
|
|
$unconnected_count--;
|
|
my $ftype = $chan->field_type;
|
|
my $count = $chan->element_count;
|
|
$ftype = 'DBR_LONG' if $ftype eq 'DBR_CHAR' && $count == 1;
|
|
print " Getting ${\$chan->name} as $ftype\n" if $opt_D;
|
|
# We have to fetch all elements so we can show how many there are
|
|
$chan->get_callback(\&caget_callback, $ftype);
|
|
$callback_incomplete++;
|
|
}
|
|
|
|
sub caget_callback {
|
|
my ($chan, $status, $data) = @_;
|
|
die $status if $status;
|
|
print " Got ${\$chan->name} = '$data'\n" if $opt_D;
|
|
$callback_data{$chan->name} = $data;
|
|
$callback_incomplete--;
|
|
}
|
|
|
|
# Given record name and interest level prints data from record fields
|
|
# that are at or below the interest level specified.
|
|
# Usage: printRecord($recordName, $interestLevel)
|
|
sub printRecord {
|
|
my ($name, $interest) = @_;
|
|
|
|
my $recType = getRecType($name);
|
|
print("Record $name type $recType\n");
|
|
die "Record type $recType not found\n"
|
|
unless exists $record{$recType};
|
|
|
|
#capture list of fields
|
|
my @readlist = (); #fields to read via CA
|
|
my @fields_pr = (); #fields for print-out
|
|
my @ftypes = (); #types, from parser
|
|
my @bases = (); #bases, from parser
|
|
foreach my $field (sort keys %{$record{$recType}}) {
|
|
my ($fType, $fInterest, $base, $special, $size) =
|
|
getFieldParams($recType, $field);
|
|
next if $fInterest > $interest;
|
|
my $fToGet = "$name.$field";
|
|
if ($fType eq 'DBF_NOACCESS') {
|
|
next unless $special eq 'SPC_DBADDR';
|
|
$fType = 'DBF_STRING';
|
|
}
|
|
elsif ($fType eq 'DBF_STRING' && $size >= 40) {
|
|
$fToGet .= '$';
|
|
}
|
|
push @fields_pr, $field;
|
|
push @readlist, $fToGet;
|
|
push @ftypes, $fType;
|
|
push @bases, $base;
|
|
}
|
|
my $fields_read = caget( @readlist );
|
|
|
|
my @missing;
|
|
|
|
# print while iterating over lists gathered
|
|
my $col = 0;
|
|
for (my $i=0; $i < scalar @readlist; $i++) {
|
|
my $field = $fields_pr[$i];
|
|
my $fToGet = $readlist[$i];
|
|
my ($fType, $data, $base);
|
|
push @missing, $field unless exists $callback_data{$fToGet};
|
|
next unless exists $callback_data{$fToGet};
|
|
$fType = $ftypes[$i];
|
|
$base = $bases[$i];
|
|
$data = $callback_data{$fToGet};
|
|
$col = printField($field, $data, $fType, $base, $col);
|
|
}
|
|
print("\n"); # Final newline
|
|
|
|
printf "\nUnreadable fields: %s\n", join(', ', @missing) if @missing && $opt_D;
|
|
}
|
|
|
|
# Prints list of record types found in dbd file. If level > 0
|
|
# then uses printRecordList to display all fields in each record type.
|
|
sub printList {
|
|
my $level = shift;
|
|
|
|
foreach my $rkey (sort keys(%record)) {
|
|
if ($level > 0) {
|
|
printRecordList($rkey);
|
|
}
|
|
else {
|
|
print(" $rkey\n");
|
|
}
|
|
}
|
|
}
|
|
|
|
# Prints list of fields and metadata for given record type
|
|
sub printRecordList {
|
|
my $type = shift;
|
|
|
|
if (exists($record{$type}) ) {
|
|
print("Record type - $type\n");
|
|
foreach my $fkey (sort keys %{$record{$type}}) {
|
|
my $param = $record{$type}{$fkey};
|
|
my $dbfType = $param->{dbfType};
|
|
printf " %-8s", $fkey;
|
|
printf " interest = %d", $param->{interest};
|
|
printf " type = %-12s", $dbfType;
|
|
if ($dbfType eq 'DBF_STRING') {
|
|
printf " size = %s\n", $param->{size};
|
|
}
|
|
elsif ($dbfType =~ m/DBF_U?(CHAR|SHORT|INT|LONG|INT64)/) {
|
|
printf " base = %s\n", $param->{base};
|
|
}
|
|
elsif ($dbfType eq 'DBF_NOACCESS') {
|
|
printf " special = %s\n", $param->{special};
|
|
}
|
|
else {
|
|
print "\n";
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
print("Record type $type not defined in dbd file $opt_d\n");
|
|
}
|
|
}
|
|
|
|
sub HELP_MESSAGE {
|
|
print STDERR "\n",
|
|
"Usage: capr.pl -h\n",
|
|
" capr.pl [options] -r\n",
|
|
" capr.pl [options] -f <record type>\n",
|
|
" capr.pl [options] <record name> [<interest>]\n",
|
|
"\n",
|
|
" -h Print this help message.\n",
|
|
" -D Print debug messages.\n",
|
|
"Channel Access options:\n",
|
|
" -w <sec>: Wait time, specifies CA timeout, default is $opt_w second\n",
|
|
"Database Definitions:\n",
|
|
" -d <file.dbd>: The file containing record type definitions.\n",
|
|
" This can be set using the EPICS_CAPR_DBD_FILE environment variable.\n",
|
|
" Default: ", abs_path($opt_d), "\n",
|
|
"Output Options:\n",
|
|
" -r Lists all record types in the selected dbd file.\n",
|
|
" -f <record type>: Lists all fields with interest level, data type\n",
|
|
" and other information for the given record_type.\n",
|
|
" -l <interest>: interest level\n",
|
|
" -n <elems>: Maximum number of array elements to display\n",
|
|
" Default: $opt_n\n",
|
|
"\n",
|
|
"Base version: ", CA->version, "\n";
|
|
exit 1;
|
|
}
|