From f21ec435606407e39e3914cddf77962e46ac9f13 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Fri, 27 Jun 2008 22:19:30 +0000 Subject: [PATCH] Added Perl5 interface to CA. Not tested on Windows... --- src/Makefile | 2 + src/cap5/CA.pm@ | 610 +++++++++++++++++ src/cap5/Cap5.xs | 1449 ++++++++++++++++++++++++++++++++++++++++ src/cap5/Makefile | 53 ++ src/cap5/caget.pl@ | 154 +++++ src/cap5/cainfo.pl@ | 63 ++ src/cap5/camonitor.pl@ | 137 ++++ src/cap5/caput.pl@ | 181 +++++ src/cap5/perlConfig.pl | 9 + 9 files changed, 2658 insertions(+) create mode 100644 src/cap5/CA.pm@ create mode 100644 src/cap5/Cap5.xs create mode 100644 src/cap5/Makefile create mode 100644 src/cap5/caget.pl@ create mode 100644 src/cap5/cainfo.pl@ create mode 100644 src/cap5/camonitor.pl@ create mode 100644 src/cap5/caput.pl@ create mode 100644 src/cap5/perlConfig.pl diff --git a/src/Makefile b/src/Makefile index 5adbb3505..4f1988e34 100644 --- a/src/Makefile +++ b/src/Makefile @@ -20,6 +20,7 @@ DIRS += RTEMS DIRS += libCom/test DIRS += toolsComm DIRS += dbStatic +DIRS += cap5 DIRS += registry DIRS += bpt DIRS += db @@ -46,6 +47,7 @@ RTEMS_DEPEND_DIRS = libCom libCom/test_DEPEND_DIRS = libCom RTEMS toolsComm_DEPEND_DIRS = libCom dbStatic_DEPEND_DIRS = toolsComm +cap5_DEPEND_DIRS = ca dbStatic registry_DEPEND_DIRS = dbStatic bpt_DEPEND_DIRS = dbStatic db_DEPEND_DIRS = bpt ca diff --git a/src/cap5/CA.pm@ b/src/cap5/CA.pm@ new file mode 100644 index 000000000..c29dda585 --- /dev/null +++ b/src/cap5/CA.pm@ @@ -0,0 +1,610 @@ +# Bootstrap wrapper for the Perl 5 Channel Access client module. +# This wrapper also contains the POD documentation for the module. + +use strict; +use warnings; + +my $version = '0.2'; + +exists $ENV{EPICS_HOST_ARCH} + or die "EPICS_HOST_ARCH environment variable not set"; + + +package CA; + +our $VERSION = $version; + + +package Cap5; +# This package is required because the loadable library containing the +# Perl interface code shouldn't be called CA but DynaLoader needs the +# package name to match the library name. The loadable library actually +# declares the packages for both Cap5 and CA which is why this works, +# although the only symbols in the Cap5 package are associated with the +# requirements of the DynaLoader module. + +our $VERSION = $version; +our @ISA = qw(DynaLoader); + +require DynaLoader; + +# Add our lib/ directory to the library search path +push @DynaLoader::dl_library_path, '@TOP@/lib/'.$ENV{EPICS_HOST_ARCH}; + +bootstrap Cap5 $VERSION; + + +package CA::Subscription; +# A subscription reference is a distinct object type. This package +# provides a convenience method allowing a subscription to clear itself. + +our $VERSION = $version; + +sub clear { + CA->clear_subscription(shift); +} + +1; +__END__ + +=head1 NAME + +CA - Perl 5 interface to EPICS Channel Access + +=head1 SYNOPSIS + + use lib '/path/to/cap5/lib/perl'; + use CA; + + my $chan = CA->new('pvname'); + CA->pend_io(1); + + my @access = ('no ', ''); + printf " PV name: %s\n", $chan->name; + printf " Data type: %s\n", $chan->field_type; + printf " Element count: %d\n", $chan->element_count; + printf " Host: %s\n", $chan->host_name; + printf " State: %s\n", $chan->state; + printf " Access: %sread, %swrite\n", + $access[$chan->read_access], $access[$chan->write_access]; + + die "PV not found!" unless chan->is_connected; + + $chan->get; + CA->pend_io(1); + printf " Value: %s\n", $chan->value; + + $chan->create_subscription('v', \&callback, 'DBR_TIME_DOUBLE'); + CA->pend_event(10); + + sub callback { + my ($chan, $status, $data) = @_; + if ($status) { + printf "%-30s %s\n", $chan->name, $status; + } else { + printf " Value: %g\n", $data->{value}; + printf " Severity: %s\n", $data->{severity}; + printf " Timestamp: %d.%09d\n", + $data->{stamp}, $data->{stamp_fraction}; + } + } + + +=head1 DESCRIPTION + +C is an efficient interface to the EPICS Channel Access client library for +use by Perl 5 programs. It provides most of the functionality of the C library +(omitting Synchronous Groups) but only handles the three standard Perl data +types integer (long), floating point (double) and string. Programmers who +understand the C API will very quickly pick up how to use this library since the +calls and concepts are virtually identical. + + +=head1 FUNCTIONS + + +=head2 Constructor + +=over 4 + +=item new( I ) + +=item new( I, I ) + +Create a channel for the named PV. If given, I will be called whenever the +connection state of the channel changes. The arguments passed to I are the +channel object and a scalar value that is true if the channel is now up. + +The underlying CA channel will be cleaned up properly when the channel object is +garbage-collected by Perl. + +=back + + +=head2 Object Methods + +The following methods are provided for channel objects returned by +C<< CA->new() >>. + +=over 4 + + +=item name + +The PV name provided when this channel was created. + + +=item field_type + +Returns the native DBF type of the process variable as a string, or the string +C if unconnected. + + +=item element_count + +The maximum array element count from the server. Zero if the channel is not +connected. + + +=item host_name + +A string containing the server's hostname and port number. If the channel is +disconnected it will report C<< >>. + + +=item read_access + +=item write_access + +A true/false value that indicates whether the client has read or write access to +the specified channel. + + +=item state + +A string giving the current connection state of the channel, one of C, C, C or C. + + +=item is_connected + +Returns C if the channel is currently connected, else C. Use this +in preference to the equivalent code Sstate eq 'connected' >>>. + + +=item get + +=item value + +The C method makes a C request for a single element of the Perl +type closest to the channel's native data type (C fields will be +fetched as strings). Once the server has returned the value (for which see the +C function below) it can be retrieved using the channel's C +method. Note that this method deliberately has only very limited capabilities; +the C method must be used for more complex requirements. + + +=item get_callback( I ) + +=item get_callback( I, I ) + +=item get_callback( I, I ) + +=item get_callback( I, I, I ) + +The C method takes a subroutine reference or name and calls that +routine when the server returns the data requested. With no other arguments the +request will be for native data type of the channel, and if the channel is an +array it will request all possible array elements. The subroutine will be +called with three arguments: the channel object, a status value from the server, +and the returned data. If there was no error the status value will be C +and the data will be valid; if there was an error the data will be C and +the status is a printable string giving more information. The format of the +data is described under L below. + +The element count can be overridden by providing an integer argument in the +range 1 .. C. The data type can also be given as a string naming +the desired C type; the actual type used will have the C part +widened to one of C, C or C. The valid type names are +listed in the L under the section +titled Channel Access Data Types; look in the CA Type Code column of the two +tables + + +=item create_subscription( I, I ) + +=item create_subscription( I, I, I ) + +=item create_subscription( I, I, I ) + +=item create_subscription( I, I, I, I ) + +Register a state change subscription and specify a subroutine to be called +whenever the process variable undergoes a significant state change. I +must be a string containing one or more of the letters C, C and C which +indicate that this subscription is for Value, Log or Alarm changes. The +subroutine I is called as described in the C method, and the +same optional I and I arguments may be supplied to modify the data +type and element count requested from the server. + +The C method returns a C object which is +required to cancel that particular subscription. Either call the C +method on that object directly, or pass it to the C<< CA->clear_subscription >> +class method. + + +=item put( I ) + +=item put( I, I, ... ) + +The C method makes a C or C call depending on the +number of elements given in its argument list. For single values the data type +used depends on the actual data item provided by Perl. For arrays the data type +used will be the native type of the channel widened to one of C, C +or C. + + +=item put_callback( I, I ) + +=item put_callback( I, I, I, ... ) + +C is similar to the C method with the addition of the +subroutine reference or name I which is called when the server reports that +all actions resulting from the put have completed. For some applications this +callback can be delayed by minutes, hours or possibly even longer. The data +type is chosen the same way as for C. The arguments to the subroutine will +be the channel object and the status value from the server which is C or +a printable string if an error occurred. + + +=item put_acks( I ) + +=item put_acks( I, I ) + +Applications that need to ackowledge alarms by doing a C with type +C can do so using the C method. The severity argument +can be an integer from zero through three or a string containing one of the +corresponding EPICS severity names C, C, C or +C. If a subroutine reference is provided it will be called as describe +in C above. + + +=item put_ackt( I ) + +=item put_ackt( I, I ) + +This method is for applications that need to enable/disable transient alarms by +doing a C with type C. The C argument is a +true/false value, and an optional subroutine reference can be provided as +above. + + +=item change_connection_event( I ) + +This method replaces, adds or cancels the connection handler subroutine for the +channel; see the C constructor for details. If I is C any +existing handler is removed, otherwise the new subroutine will be used for all +future connection events on this channel. + +=back + + +=head2 Channel Data + +The data provided to a callback function registered with either C +or C can be a scalar value or a reference to an array or a +hash, depending on the data type that was used for the data transfer. If the +request was for a single item of one of the basic data types, the data argument +will be a perl scalar that holds the value directly. If the request was for +multiple items of one of the basic types, the data argument will be a reference +to an array holding the data. + +If the request was for one of the compound data types, the data argument will be +a reference to a hash with keys as described below. Keys that are not classed +as metadata are named directly after the fields in the C C, +and are only included when the C structure contains that particular field. + + +=head3 Metadata + +These metadata will always be present in the hash: + + +=over 4 + +=item TYPE + +The C name of the data type from the server. + + +=item COUNT + +The number of elements in the data returned by the server. + +=back + + +=head3 Fixed Fields + +These fields are always present in the hash: + +=over 4 + + +=item value + +The actual process variable data. If I is 1 C will be the data as +a scalar; if the channel returned multiple elements, C will be a +reference to an array of scalars. + +If I is C or C, C can be accessed both +as the integer choice value and (if within range) as the string associated with +that particular choice. + + +=item status + +The alarm status of the PV as a printable string, or C if not in alarm. + + +=item severity + +The alarm severity of the PV, or C if not in alarm. A defined severity +can be used as a human readable string or as a number giving the numeric value +of the alarm severity (1 = MINOR, 2 = MAJOR, 3 = INVALID). + +=back + + +=head3 Ephemeral Fields + +These fields are only present for some values of I: + +=over 4 + + +=item strs + +A reference to an array containing all the possible choice strings for an ENUM. + +Present only when I is C or C. + + +=item no_str + +The number of choices defined for an ENUM. + +Present only when I is C or C. + + +=item stamp + +The process variable timestamp, converted to a local C. This value is +suitable for passing to the perl C or C functions. + +Present only when I is C. + +=item stamp_fraction + +The fractional part of the process variable timestamp as a positive floating +point number less than 1.0. + +Present only when I is C. + + +=item ackt + +The value of the process variable's transient acknowledgment flag, an integer. + +Present only when I is C. + + +=item acks + +The alarm severity of the highest unacknowledged alarm for this process +variable. As with the C value, this scalar is both a string and +numeric severity. + +Present only when I is C. + + +=item precision + +The process variable's display precision, an integer giving the number of +decimal places to display. + +Present only when I is C or C. + + +=item units + +The engineering units string for the process variable. + +Present only when I is C or C where C is +not C. + + +=item upper_disp_limit + +=item lower_disp_limit + +The display range for the process variable; graphical tools often provide a way +to override these limits. + +Present only when I is C or C where C is +not C. + + +=item upper_alarm_limit + +=item upper_warning_limit + +=item lower_warning_limit + +=item lower_alarm_limit + +These items give the values at which the process variable should go into an +alarm state, although in practice the alarm severity associated with each level +is not provided. + +Present only when I is C or C where C is +not C. + + +=item upper_ctrl_limit + +=item lower_ctrl_limit + +The range over which a client can control the value of the process variable. + +Present only when I is C where C is not C. + +=back + + +=head2 Class Methods + + +The following functions are not channel methods, and should be called using the +class method syntax, e.g. C<< CA->pend_io(10) >>. + +=over 4 + +=item flush_io + +Flush outstanding IO requests to the server. This routine is useful for users +who need to flush requests prior to performing client side labor in parallel +with labor performed in the server. Outstanding requests are also sent whenever +the buffer which holds them becomes full. + + +=item test_io + +This function tests to see if all C requests are complete and channels +created without a connection callback subroutine are connected. It will return +a true value if all such operations are complete, otherwise false. + + +=item pend_io( I ) + +This function flushes the send buffer and then blocks until all outstanding +C requests complete and all channels created without a connection callback +subroutine have connected for the first time. Unlike C, this +routine does not process CA's background activities if no IO requests are +pending. + +If any I/O or connection operations remain incomplete after I seconds, +the function will die with the error C; see L +below. A I interval of zero is taken to mean wait forever if +necessary. The I value should take into account worst case network +delays such as Ethernet collision exponential back off until retransmission +delays which can be quite long on overloaded networks. + + +=item pend_event( I ) + +Flush the send buffer and process CA's background activities for I +seconds. This function always blocks for the full I period, and if a +value of zero is used it will never return. + + +=item poll + +Flush the send buffer and process any outstanding CA background activity. + + +=item clear_subscription( I ) + +Cancel a subscription. Note that for this to take effect immediately it is +necessary to call C<< CA->flush_io >> or one of the other class methods that +flushes the send buffer. + + +=item add_exception_event( I ) + +Trap exception events and execute I whenever they occur. The subroutine is +provided with four arguments: The channel object (if applicable), the status +value from the server, a printable context string giving more information about +the error, and a hash reference containing some additional data. If the +exception is not specific to a particular channel the channel object will be +C. The status value is a printable string. The hash may contain any of +the following members: + +=over 8 + +=item * OP + +The operation in progress when the exception occurred. This scalar when used as +a string is one of C, C, C, C, +C or C but can also be accessed as an integer (0-5). + +=item * TYPE + +The C name of the data type involved. + +=item * COUNT + +The number of elements in the request. + +=item * FILE + +=item * LINE + +These refer to the source file and line number inside the CA client library +where the exception was noticed. + +=back + +=item replace_printf_handler( I ) + +This function provides a method to trap error messages from the CA client +library and redirect them to some other place than the C stream. The +subroutine provided will be called with a single string argument every time the +client library wishes to output an error or warning message. Note that a single +message may result in several calls to this subroutine. + +To revert back to the original handler, call C<< CA->replace_printf_handler() >> +passing C as the subroutine reference. + +=back + + +=head1 ERROR HANDLING + +Errors in using the library will be indicated by the module throwing an +exception, i.e. calling C with an appropriate error message. These +exceptions can be caught using the standard Parl C statement and +testing the C<$@> variable afterwards; if not caught, they will cause the +running program to C with an appropriate error message pointing to the +program line that called the C library. + +Errors messages reported by the underlying CA client library all start with the +string C and the remainder of the symbol for the associated CA error +number, and are followed after a space-hyphen-space by a human-readable message +describing the error. Errors that are detected by the perl interface layer do +not follow this pattern, but are still printable strings. + + +=head1 SEE ALSO + +=over + +=item [1] R3.14 Channel Access Reference Manual by Jeffrey O. Hill + +L + +=back + + +=head1 AUTHOR + +Andrew Johnson, Eanj@aps.anl.govE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2008 UChicago Argonne LLC, as Operator of Argonne National +Laboratory. + +This software is distributed under the terms of the EPICS Open License. + +=cut diff --git a/src/cap5/Cap5.xs b/src/cap5/Cap5.xs new file mode 100644 index 000000000..bc2f4b88f --- /dev/null +++ b/src/cap5/Cap5.xs @@ -0,0 +1,1449 @@ +/* Provides an EPICS Channel Access client interface for Perl5. */ + +/* ToDo: + * CA::add_exception_event($class, \&sub) + */ + +/* This macro disables perl's reentr.inc file, which we don't need + * here and just generates unnecessary compiler warnings. */ +#define REENTRINC + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "cadef.h" +#include "db_access.h" +#include "alarm.h" +#include "alarmString.h" + +typedef union { + dbr_long_t iv; + dbr_double_t nv; + dbr_string_t pv; +} CA_data; + +typedef struct CA_channel { + chid chan; + CA_data data; + SV *chan_ref; + SV *conn_sub; + SV *rights_sub; +} CA_channel; + +static +void *p5_ctx; + +static +const char * get_error_msg(int status) { + static const char * const messages[] = { + "ECA_NORMAL - Normal successful completion", + "ECA_MAXIOC - Maximum simultaneous IOC connections exceeded", + "ECA_UKNHOST - Unknown internet host", + "ECA_UKNSERV - Unknown internet service", + "ECA_SOCK - Unable to allocate a new socket", + "ECA_CONN - Unable to connect to internet host or service", + "ECA_ALLOCMEM - Unable to allocate additional dynamic memory", + "ECA_UKNCHAN - Unknown IO channel", + "ECA_UKNFIELD - Record field specified inappropriate for channel specified", + "ECA_TOLARGE - The requested data transfer is greater than available memory or EPICS_CA_MAX_ARRAY_BYTES", + "ECA_TIMEOUT - User specified timeout on IO operation expired", + "ECA_NOSUPPORT - Sorry, that feature is planned but not supported at this time", + "ECA_STRTOBIG - The supplied string is unusually large", + "ECA_DISCONNCHID - The request was ignored because the specified channel is disconnected", + "ECA_BADTYPE - The data type specifed is invalid", + "ECA_CHIDNOTFND - Remote Channel not found", + "ECA_CHIDRETRY - Unable to locate all user specified channels", + "ECA_INTERNAL - Channel Access Internal Failure", + "ECA_DBLCLFAIL - The requested local DB operation failed", + "ECA_GETFAIL - Channel read request failed", + "ECA_PUTFAIL - Channel write request failed", + "ECA_ADDFAIL - Channel subscription request failed", + "ECA_BADCOUNT - Invalid element count requested", + "ECA_BADSTR - Invalid string", + "ECA_DISCONN - Virtual circuit disconnect", + "ECA_DBLCHNL - Identical process variable names on multiple servers", + "ECA_EVDISALLOW - Request inappropriate within subscription (monitor) update callback", + "ECA_BUILDGET - Database value get for that channel failed during channel search", + "ECA_NEEDSFP - Unable to initialize without the vxWorks VX_FP_TASK task option set", + "ECA_OVEVFAIL - Event queue overflow has prevented first pass event after event add", + "ECA_BADMONID - Bad event subscription (monitor) identifier", + "ECA_NEWADDR - Remote channel has new network address", + "ECA_NEWCONN - New or resumed network connection", + "ECA_NOCACTX - Specified task isnt a member of a CA context", + "ECA_DEFUNCT - Attempt to use defunct CA feature failed", + "ECA_EMPTYSTR - The supplied string is empty", + "ECA_NOREPEATER - Unable to spawn the CA repeater thread- auto reconnect will fail", + "ECA_NOCHANMSG - No channel id match for search reply- search reply ignored", + "ECA_DLCKREST - Reseting dead connection- will try to reconnect", + "ECA_SERVBEHIND - Server (IOC) has fallen behind or is not responding- still waiting", + "ECA_NOCAST - No internet interface with broadcast available", + "ECA_BADMASK - Invalid event selection mask", + "ECA_IODONE - IO operations have completed", + "ECA_IOINPROGRESS - IO operations are in progress", + "ECA_BADSYNCGRP - Invalid synchronous group identifier", + "ECA_PUTCBINPROG - Put callback timed out", + "ECA_NORDACCESS - Read access denied", + "ECA_NOWTACCESS - Write access denied", + "ECA_ANACHRONISM - Requested feature is no longer supported", + "ECA_NOSEARCHADDR - Empty PV search address list", + "ECA_NOCONVERT - No reasonable data conversion between client and server types", + "ECA_BADCHID - Invalid channel identifier", + "ECA_BADFUNCPTR - Invalid function pointer", + "ECA_ISATTACHED - Thread is already attached to a client context", + "ECA_UNAVAILINSERV - Not supported by attached service", + "ECA_CHANDESTROY - User destroyed channel", + "ECA_BADPRIORITY - Invalid channel priority", + "ECA_NOTTHREADED - Preemptive callback not enabled - additional threads may not join context", + "ECA_16KARRAYCLIENT - Client's protocol revision does not support transfers exceeding 16k bytes", + "ECA_CONNSEQTMO - Virtual circuit connection sequence aborted", + "ECA_UNRESPTMO - Virtual circuit unresponsive" + }; + + return messages[CA_EXTRACT_MSG_NO(status)]; +} + + +static +chtype best_type(CA_channel *pch) { + switch (ca_field_type(pch->chan)) { + case DBF_STRING: + case DBF_ENUM: + return DBF_STRING; + case DBF_INT: + case DBF_CHAR: + case DBF_LONG: + return DBF_LONG; + case DBF_FLOAT: + case DBF_DOUBLE: + return DBF_DOUBLE; + } + croak("Unexpected field type %s", + dbf_type_to_text(ca_field_type(pch->chan))); +} + + +static +SV * newSVdbf(chtype type, const void *dbr, int index) { + switch (type) { + char *pc; + size_t len; + case DBR_STRING: + pc = (char *)dbr + index * MAX_STRING_SIZE; + len = strlen(pc); + return newSVpv(pc, len < MAX_STRING_SIZE ? len : MAX_STRING_SIZE); + case DBR_LONG: + return newSViv(((dbr_long_t *)dbr)[index]); + case DBR_DOUBLE: + return newSVnv(((dbr_double_t *)dbr)[index]); + default: + croak("Unexpected data type %s", dbf_type_to_text(type)); + } +} + + +static +SV * newSValarm(int sevr) { + SV *alarm = &PL_sv_undef; + if (sevr) { + alarm = newSViv(sevr); + sv_setpv(alarm, alarmSeverityString[sevr]); + SvIOK_on(alarm); + } + return alarm; +} + + +static +SV * newSVdbr(struct event_handler_args *peha) { + const int is_primitive = dbr_type_is_plain(peha->type) || + (peha->type == DBR_CLASS_NAME); + HV *hash; + SV *val; + chtype value_type; + union db_access_val *u; + + if (dbr_type_is_STRING(peha->type) || + peha->type == DBR_STSACK_STRING || + peha->type == DBR_CLASS_NAME) + value_type = DBR_STRING; + else if (dbr_type_is_LONG(peha->type)) + value_type = DBR_LONG; + else if (dbr_type_is_DOUBLE(peha->type)) + value_type = DBR_DOUBLE; + else if (dbr_type_is_ENUM(peha->type)) + /* Only seen as DBR_GR_ENUM and DBR_CTRL_ENUM */ + value_type = DBR_ENUM; + else { + croak("Unexpected data type %s", + dbf_type_to_text(peha->type)); + } + + if (is_primitive && peha->count == 1) { /* Primitive => Scalar */ + return newSVdbf(value_type, peha->dbr, 0); + } + + if (is_primitive) { /* Array => Array Ref */ + AV *array = newAV(); + int i; + for (i = 0; i < peha->count; i++) { + av_push(array, newSVdbf(value_type, peha->dbr, i)); + } + return newRV_noinc((SV *)array); + } + + u = (union db_access_val *)peha->dbr; /* Compound => Hash Ref */ + hash = newHV(); + + /* Meta-data */ + hv_store(hash, "TYPE", 4, + newSVpv(dbr_type_to_text(peha->type), 0), 0); + hv_store(hash, "COUNT", 5, newSViv(peha->count), 0); + + /* Alarm status and severity are always in the same place */ + if (u->slngval.status) + val = newSVpv(alarmStatusString[u->slngval.status], 0); + else + val = &PL_sv_undef; + hv_store(hash, "status", 6, val, 0); + hv_store(hash, "severity", 8, + newSValarm(u->slngval.severity), 0); + + if (peha->type == DBR_GR_ENUM || + peha->type == DBR_CTRL_ENUM) { + AV *strings = newAV(); + int n = u->genmval.no_str; + int i; + + val = newSViv(u->genmval.value); + + for (i = 0; i < n; i++) { + size_t slen = strlen(u->genmval.strs[i]); + if (slen > MAX_ENUM_STRING_SIZE) + slen = MAX_ENUM_STRING_SIZE; + av_push(strings, newSVpv(u->genmval.strs[i], slen)); + if (i == u->genmval.value) { + sv_setpvn(val, u->genmval.strs[i], slen); + SvIOK_on(val); + } + } + hv_store(hash, "strs", 4, + newRV_noinc((SV *)strings), 0); + hv_store(hash, "no_str", 6, + newSViv(u->genmval.no_str), 0); + hv_store(hash, "value", 5, val, 0); + + return newRV_noinc((SV *)hash); + } + + /* Value */ + if (peha->count == 1) { + val = newSVdbf(value_type, + dbr_value_ptr(peha->dbr, peha->type), 0); + } else { + AV *array = newAV(); + int i; + for (i = 0; i < peha->count; i++) { + av_push(array, newSVdbf(value_type, + dbr_value_ptr(peha->dbr, peha->type), i)); + } + val = newRV_noinc((SV *)array); + } + hv_store(hash, "value", 5, val, 0); + + /* Timestamp follows status and severity in DBR_TIME */ + if (dbr_type_is_TIME(peha->type)) { + struct timespec t; + epicsTimeToTimespec(&t, &u->tlngval.stamp); + hv_store(hash, "stamp", 5, + newSViv(t.tv_sec), 0); + hv_store(hash, "stamp_fraction", 14, + newSVnv((double)t.tv_nsec / 1e9), 0); + } + else if (peha->type == DBR_STSACK_STRING) { + struct dbr_stsack_string *s = (struct dbr_stsack_string *)peha->dbr; + hv_store(hash, "ackt", 4, + newSViv(s->ackt), 0); + hv_store(hash, "acks", 4, + newSValarm(s->acks), 0); + } + else if (value_type != DBR_STRING && + (dbr_type_is_GR(peha->type) || + dbr_type_is_CTRL(peha->type))) { + char *units; + size_t ulen; + void *limit; + int i = dbr_type_is_CTRL(peha->type) ? 7 : 5; + + if (value_type == DBR_DOUBLE) { + units = u->gdblval.units; + limit = &u->gdblval.upper_disp_limit; + hv_store(hash, "precision", 9, + newSViv(u->gdblval.precision), 0); + } else { /* value_type == DBR_LONG */ + units = u->glngval.units; + limit = &u->glngval.upper_disp_limit; + } + + ulen = strlen(units); + hv_store(hash, "units", 5, newSVpv(units, + ulen < MAX_UNITS_SIZE ? ulen : MAX_UNITS_SIZE), 0); + + while (i >= 0) { + static const char * const limit_name[] = { + "upper_disp_limit", "lower_disp_limit", + "upper_alarm_limit", "upper_warning_limit", + "lower_warning_limit", "lower_alarm_limit", + "upper_ctrl_limit", "lower_ctrl_limit", + }; + hv_store(hash, limit_name[i], strlen(limit_name[i]), + newSVdbf(value_type, limit, i), 0); + i--; + } + } + + return newRV_noinc((SV *)hash); +} + + +enum io_type { + IO_GET, + IO_PUT, + IO_MONITOR, +}; + +static +void io_handler(struct event_handler_args *peha, enum io_type io) { + PERL_SET_CONTEXT(p5_ctx); + { + CA_channel *pch = ca_puser(peha->chid); + SV *code = (SV *)peha->usr; + SV *status = &PL_sv_undef; + SV *data = &PL_sv_undef; + dSP; + + ENTER; + SAVETMPS; + + if (peha->status != ECA_NORMAL) { + status = sv_2mortal(newSVpv(get_error_msg(peha->status), 0)); + } else if (io != IO_PUT) { + data = sv_2mortal(newSVdbr(peha)); + } + + sv_setsv(ERRSV, &PL_sv_undef); + + PUSHMARK(SP); + XPUSHs(pch->chan_ref); + XPUSHs(status); + XPUSHs(data); + PUTBACK; + + call_sv(code, G_VOID | G_DISCARD | G_EVAL | G_KEEPERR); + + if (io != IO_MONITOR) + SvREFCNT_dec(code); + + if (SvTRUE(ERRSV)) + croak(Nullch); + + FREETMPS; + LEAVE; + } +} + + +static +int replace_handler(SV * sub, SV ** ph_sub, long *phandler) { + if (SvOK(sub) && SvTRUE(sub)) { + if (*ph_sub != NULL) { + SvSetSV(*ph_sub, sub); + return FALSE; + } + *ph_sub = newSVsv(sub); + } else { + if (*ph_sub == NULL) + return FALSE; + + SvREFCNT_dec(*ph_sub); + *ph_sub = NULL; + *phandler = 0; + } + + return TRUE; +} + + +/******************************************************************************/ + +/* CA::new($class, $name, [\&sub]) */ + +static +void connect_handler(struct connection_handler_args cha) { + CA_channel *pch = ca_puser(cha.chid); + + PERL_SET_CONTEXT(p5_ctx); + { + dSP; + + SvSetSV(ERRSV, &PL_sv_undef); + + PUSHMARK(SP); + XPUSHs(pch->chan_ref); + XPUSHs(cha.op == CA_OP_CONN_UP ? &PL_sv_yes : &PL_sv_no); + PUTBACK; + + call_sv(pch->conn_sub, G_EVAL | G_VOID | G_DISCARD | G_KEEPERR); + + if (SvTRUE(ERRSV)) + croak(Nullch); + } +} + +SV * CA_new(const char *class, const char *name, ...) { + dXSARGS; + SV *ca_ref = newSViv(0); + SV *ca_obj = newSVrv(ca_ref, class); + CA_channel *pch; + caCh *handler; + int status; + + Newz(0, pch, 1, CA_channel); + sv_setiv(ca_obj, (IV)pch); + SvREADONLY_on(ca_obj); + + pch->chan_ref = ca_ref; + SvREFCNT_inc(ca_ref); + + if (items > 2 + && SvOK(ST(2))) { + /* Connection handler provided */ + pch->conn_sub = newSVsv(ST(2)); + handler = &connect_handler; + } else + handler = NULL; + + status = ca_create_channel(name, handler, pch, 0, &pch->chan); + if (status != ECA_NORMAL) { + SvREFCNT_dec(ca_ref); + if (pch->conn_sub) + SvREFCNT_dec(pch->conn_sub); + croak(get_error_msg(status)); + } + + return ca_ref; +} + + +/* CA::DESTROY($ca_ref) */ + +void CA_DESTROY(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + int status; + + status = ca_clear_channel(pch->chan); + + if (pch->conn_sub) + SvREFCNT_dec(pch->conn_sub); + + if (pch->rights_sub) + SvREFCNT_dec(pch->rights_sub); + + SvREFCNT_dec(pch->chan_ref); + Safefree(pch); + + if (status != ECA_NORMAL) { + croak(get_error_msg(status)); + } +} + + +/* CA::change_connection_event($ca_ref, \$sub) */ + +void CA_change_connection_event(SV *ca_ref, SV *sub) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + caCh *handler = &connect_handler; + int status; + + if (! replace_handler(sub, &pch->conn_sub, (long *)&handler)) + return; + + status = ca_change_connection_event(pch->chan, handler); + + if (status != ECA_NORMAL) { + croak(get_error_msg(status)); + } +} + + +/* CA::put($ca_ref, @values) */ + +void CA_put(SV *ca_ref, SV *val, ...) { + dXSARGS; + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + int num_values = items - 1; + int status; + + if (num_values == 1) { + union { + dbr_long_t dbr_long; + dbr_double_t dbr_double; + dbr_string_t dbr_string; + } data; + chtype type; + + if (SvIOKp(val)) { + data.dbr_long = SvIV(val); + type = DBR_LONG; + } else if (SvNOKp(val)) { + data.dbr_double = SvNV(val); + type = DBR_DOUBLE; + } else { + strncpy(data.dbr_string, SvPV_nolen(val), MAX_STRING_SIZE); + type = DBR_STRING; + } + + status = ca_put(type, pch->chan, &data); + } else { + chtype type = best_type(pch); + union { + dbr_long_t *dbr_long; + dbr_double_t *dbr_double; + char *dbr_string; + void *dbr; + } p; + int i; + + switch (type) { + case DBF_LONG: + New(0, p.dbr_long, num_values, dbr_long_t); + for (i = 0; i < num_values; i++) { + p.dbr_long[i] = SvIV(ST(i + 1)); + } + break; + case DBF_DOUBLE: + New(0, p.dbr_double, num_values, dbr_double_t); + for (i = 0; i < num_values; i++) { + p.dbr_double[i] = SvNV(ST(i + 1)); + } + break; + case DBF_STRING: + New(0, p.dbr_string, num_values * MAX_STRING_SIZE, char); + for (i = 0; i < num_values; i++) { + char * src = SvPV_nolen(ST(i + 1)); + strncpy(p.dbr_string + i, src, MAX_STRING_SIZE); + } + break; + } + + status = ca_array_put(type, num_values, pch->chan, p.dbr); + Safefree(p.dbr); + } + if (status != ECA_NORMAL) { + croak(get_error_msg(status)); + } + XSRETURN(0); +} + + +/* CA::put_callback($ca_ref, \&sub, @values) */ + +static +void put_handler(struct event_handler_args eha) { + io_handler(&eha, IO_PUT); +} + +void CA_put_callback(SV *ca_ref, SV *sub, SV *val, ...) { + dXSARGS; + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + SV *put_sub = newSVsv(sub); + int n = items - 2; + int status; + + if (n == 1) { + union { + dbr_long_t dbr_long; + dbr_double_t dbr_double; + dbr_string_t dbr_string; + } data; + chtype type; + + if (SvIOKp(val)) { + data.dbr_long = SvIV(val); + type = DBF_LONG; + } else if (SvNOKp(val)) { + data.dbr_double = SvNV(val); + type = DBF_DOUBLE; + } else { + strncpy(data.dbr_string, SvPV_nolen(val), MAX_STRING_SIZE); + type = DBF_STRING; + } + + status = ca_put_callback(type, pch->chan, &data, put_handler, put_sub); + } else { + chtype type = best_type(pch); + union { + dbr_long_t *dbr_long; + dbr_double_t *dbr_double; + char *dbr_string; + void *dbr; + } p; + int i; + + switch (type) { + case DBF_LONG: + New(0, p.dbr_long, n, dbr_long_t); + for (i = 0; i < n; i++) { + p.dbr_long[i] = SvIV(ST(i + 2)); + } + break; + case DBF_DOUBLE: + New(0, p.dbr_double, n, dbr_double_t); + for (i = 0; i < n; i++) { + p.dbr_double[i] = SvNV(ST(i + 2)); + } + break; + case DBF_STRING: + New(0, p.dbr_string, n * MAX_STRING_SIZE, char); + for (i = 0; i < n; i++) { + char * src = SvPV_nolen(ST(i + 2)); + strncpy(p.dbr_string + i, src, MAX_STRING_SIZE); + } + break; + } + + status = ca_array_put_callback(type, n, pch->chan, p.dbr, + put_handler, put_sub); + Safefree(p.dbr); + } + if (status != ECA_NORMAL) { + SvREFCNT_dec(put_sub); + croak(get_error_msg(status)); + } + XSRETURN(0); +} + + +/* CA::put_acks($ca_ref, $sevr, [\&sub]) */ + +void CA_put_acks(SV *ca_ref, SV *sevr, ...) { + dXSARGS; + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + dbr_put_acks_t acks; + int status; + + if (! SvOK(sevr)) { + acks = NO_ALARM; + } else if (SvIOK(sevr)) { + acks = SvIV(sevr); + if (acks > INVALID_ALARM) + croak("Bad acknowledgement severity %d", acks); + } else { + size_t slen; + char *sname = SvPV(sevr, slen); + for (acks = NO_ALARM; acks <= INVALID_ALARM; acks++) { + if (strcmp(sname, alarmSeverityString[acks]) == 0) + break; + } + if (acks > INVALID_ALARM) + croak("Bad acknowledgment severity '%s'", sname); + } + + if (items > 2) { + SV *put_sub = newSVsv(ST(2)); + status = ca_put_callback(DBR_PUT_ACKS, pch->chan, &acks, + put_handler, put_sub); + if (status != ECA_NORMAL) + SvREFCNT_dec(put_sub); + } else + status = ca_put(DBR_PUT_ACKS, pch->chan, &acks); + + if (status != ECA_NORMAL) + croak(get_error_msg(status)); + + XSRETURN(0); +} + + +/* CA::put_ackt($ca_ref, $trans, [\&sub]) */ + +void CA_put_ackt(SV *ca_ref, int ack, ...) { + dXSARGS; + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + dbr_put_ackt_t ackt = !! ack; /* 0 or 1 only */ + int status; + + if (items > 2) { + SV *put_sub = newSVsv(ST(2)); + status = ca_put_callback(DBR_PUT_ACKT, pch->chan, &ackt, + put_handler, put_sub); + if (status != ECA_NORMAL) + SvREFCNT_dec(put_sub); + } else + status = ca_put(DBR_PUT_ACKS, pch->chan, &ackt); + + if (status != ECA_NORMAL) + croak(get_error_msg(status)); + + XSRETURN(0); +} + + +/* CA::get($ca_ref) */ + +void CA_get(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + int status = ca_get(best_type(pch), pch->chan, &pch->data); + if (status != ECA_NORMAL) { + croak(get_error_msg(status)); + } +} + + +/* CA::value($ca_ref) */ + +SV * CA_value(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + return newSVdbf(best_type(pch), &pch->data, 0); +} + + +/* CA::get_callback($ca_ref, \&sub, [$type | $count]) */ + +static +void get_handler(struct event_handler_args eha) { + io_handler(&eha, IO_GET); +} + +void CA_get_callback(SV *ca_ref, SV *sub, ...) { + dXSARGS; + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + SV *get_sub = newSVsv(sub); + int status; + chtype type = best_type(pch); + int count = ca_element_count(pch->chan); + int i = 2; + const char *croak_msg; + + while (items > i + && SvOK(ST(i))) { + if (SvIOK(ST(i))) { + /* Interger => Count arg */ + count = SvIV(ST(i)); + if (count < 1 || count > ca_element_count(pch->chan)) { + croak_msg = "Requested array size is out of range"; + goto exit_croak; + } + } else if (SvPOKp(ST(i))) { + /* String => Type arg */ + char *treq = SvPV_nolen(ST(i)); + dbr_text_to_type(treq, type); + if (type < 0 || + type == DBR_PUT_ACKT || + type == DBR_PUT_ACKS) { + croak_msg = "Requested DBR type is invalid"; + goto exit_croak; + } else if (type == DBR_GR_ENUM || + type == DBR_CTRL_ENUM || + type == DBR_CLASS_NAME || + type == DBR_STSACK_STRING) + /* The above types are supported */ ; + else if (dbr_type_is_SHORT(type)) + type += (DBR_LONG - DBR_SHORT); + else if (dbr_type_is_FLOAT(type)) + type += (DBR_DOUBLE - DBR_FLOAT); + else if (dbr_type_is_ENUM(type)) + type += (DBR_STRING - DBR_ENUM); + else if (dbr_type_is_CHAR(type)) + type += (DBR_LONG - DBR_CHAR); + } + i++; + } + + status = ca_array_get_callback(type, count, + pch->chan, get_handler, get_sub); + if (status != ECA_NORMAL) { + croak_msg = get_error_msg(status); + goto exit_croak; + } + + XSRETURN(0); + return; + +exit_croak: + SvREFCNT_dec(get_sub); + croak(croak_msg); +} + + +/* CA::create_subscription($ca_ref, $mask, \&sub, [$type | $count]) */ + +static +void subscription_handler(struct event_handler_args eha) { + io_handler(&eha, IO_MONITOR); +} + +SV * CA_create_subscription(SV *ca_ref, const char *mask_str, SV *sub, ...) { + dXSARGS; + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + SV *mon_sub = newSVsv(sub); + SV *mon_ref = newSViv(0); + SV *mon_obj = newSVrv(mon_ref, "CA::Subscription"); + chtype type = best_type(pch); + int count = ca_element_count(pch->chan); + int i = 3; + int mask = 0; + evid event; + int status; + const char *croak_msg; + + if (strchr(mask_str, 'v') || strchr(mask_str, 'V')) mask |= DBE_VALUE; + if (strchr(mask_str, 'l') || strchr(mask_str, 'L')) mask |= DBE_LOG; + if (strchr(mask_str, 'a') || strchr(mask_str, 'A')) mask |= DBE_ALARM; + + while (items > i + && SvOK(ST(i))) { + if (SvIOK(ST(i))) { + /* Interger => Count arg */ + count = SvIV(ST(i)); + if (count < 1 || count > ca_element_count(pch->chan)) { + croak_msg = "Requested array size is out of range"; + goto exit_croak; + } + } else if (SvPOKp(ST(i))) { + /* String => Type arg */ + size_t tlen; + char *treq = SvPV(ST(i), tlen); + dbr_text_to_type(treq, type); + if (type < 0) { + croak_msg = "Unknown data type"; + goto exit_croak; + } + if (type == DBR_PUT_ACKT || + type == DBR_PUT_ACKS) { + croak_msg = "DBR_PUT_ACK types are write-only"; + goto exit_croak; + } else if (type == DBR_CLASS_NAME || + type == DBR_STSACK_STRING) + /* These break the dbr_type_is macros */ ; + else if (dbr_type_is_SHORT(type)) + type += (DBR_LONG - DBR_SHORT); + else if (dbr_type_is_FLOAT(type)) + type += (DBR_DOUBLE - DBR_FLOAT); + else if (dbr_type_is_ENUM(type)) + type += (DBR_STRING - DBR_ENUM); + else if (dbr_type_is_CHAR(type)) + type += (DBR_LONG - DBR_CHAR); + } + i++; + } + + status = ca_create_subscription(type, count, pch->chan, mask, + subscription_handler, mon_sub, &event); + if (status != ECA_NORMAL) { + croak_msg = get_error_msg(status); + goto exit_croak; + } + + sv_setiv(mon_obj, (IV)event); + SvREADONLY_on(mon_obj); + SvREFCNT_inc(mon_ref); + + return mon_ref; + +exit_croak: + SvREFCNT_dec(mon_ref); + SvREFCNT_dec(mon_sub); + croak(croak_msg); +} + + +/* CA::clear_subscription($class, $subscription) */ + +void CA_clear_subscription(const char *class, SV *mon_ref) { + evid event = (evid)SvIV(SvRV(mon_ref)); + int status; + + if (! sv_isa(mon_ref, "CA::Subscription")) { + croak("Not a CA::Subscription"); + } + + status = ca_clear_subscription(event); + + if (status != ECA_NORMAL) { + croak(get_error_msg(status)); + } +} + + +/* CA::pend_io($class, $timeout) */ + +void CA_pend_io(const char *class, double timeout) { + int status = ca_pend_io(timeout); + if (status != ECA_NORMAL) { + croak(get_error_msg(status)); + } +} + +/* CA::test_io($class) */ + +int CA_test_io(const char *class) { + return (ca_test_io() == ECA_IODONE); +} + +/* CA::pend_event($class, $timeout) */ + +void CA_pend_event(const char *class, double timeout) { + int status = ca_pend_event(timeout); + if (status != ECA_TIMEOUT) { + croak(get_error_msg(status)); + } +} + +/* CA::poll($class) */ + +void CA_poll(const char *class) { + ca_poll(); +} + + +/* CA::flush_io($class) */ + +void CA_flush_io(const char *class) { + ca_flush_io(); +} + + +/* CA::add_exception_event($class, \&sub) */ + +static +SV * exception_sub = NULL; + +static +void exception_handler(struct exception_handler_args eha) { + if (! exception_sub) + return; + + PERL_SET_CONTEXT(p5_ctx); + { + SV *channel = &PL_sv_undef; + SV *status = &PL_sv_undef; + HV *hash = newHV(); + SV *op; + const char *opString[] = { + "GET", "PUT", "CREATE_CHANNEL", "ADD_EVENT", "CLEAR_EVENT", "OTHER" + }; + dSP; + + ENTER; + SAVETMPS; + + if (eha.chid) { + CA_channel *pch = ca_puser(eha.chid); + channel = pch->chan_ref; + } + if (eha.stat != ECA_NORMAL) { + status = sv_2mortal(newSVpv(get_error_msg(eha.stat), 0)); + } + + op = newSViv(eha.op); + sv_setpv(op, opString[eha.op]); + SvIOK_on(op); + hv_store(hash, "OP", 2, op, 0); + hv_store(hash, "TYPE", 4, + newSVpv(dbr_type_to_text(eha.type), 0), 0); + hv_store(hash, "COUNT", 5, newSViv(eha.count), 0); + if (eha.pFile) + hv_store(hash, "FILE", 4, newSVpv(eha.pFile, 0), 0); + if (eha.lineNo) + hv_store(hash, "LINE", 4, newSVuv(eha.lineNo), 0); + + PUSHMARK(SP); + XPUSHs(channel); + XPUSHs(status); + XPUSHs(sv_2mortal(newSVpv(eha.ctx, 0))); + XPUSHs(sv_2mortal(newRV_noinc((SV *)hash))); + PUTBACK; + + call_sv(exception_sub, G_EVAL | G_VOID | G_DISCARD); + + FREETMPS; + LEAVE; + } +} + +void CA_add_exception_event(const char *class, SV *sub) { + caExceptionHandler *handler = exception_handler; + int status; + + if (! replace_handler(sub, &exception_sub, (long *)&handler)) + return; + + status = ca_add_exception_event(handler, NULL); + + if (status != ECA_NORMAL) { + SvREFCNT_dec(exception_sub); + exception_sub = NULL; + croak(get_error_msg(status)); + } +} + + +/* CA::replace_printf_handler($class, \&sub) */ + +static +SV * printf_sub = NULL; + +static +int printf_handler(const char *format, va_list args) { + if (! printf_sub) + return 0; + + PERL_SET_CONTEXT(p5_ctx); + { + SV *printf_str; + dSP; + va_list argcopy; + + ENTER; + SAVETMPS; + +#ifdef __GNUC__ + __va_copy(argcopy, args); +#else + va_copy(argcopy, args); +#endif + + printf_str = NEWSV(0, strlen(format) + 32); + sv_vsetpvf(printf_str, format, &argcopy); + va_end(argcopy); + + PUSHMARK(SP); + XPUSHs(sv_2mortal(printf_str)); + PUTBACK; + + call_sv(printf_sub, G_EVAL | G_VOID | G_DISCARD); + + FREETMPS; + LEAVE; + } + return 0; +} + +void CA_replace_printf_handler(const char *class, SV *sub) { + caPrintfFunc *handler = printf_handler; + int status; + + if (! replace_handler(sub, &printf_sub, (long *)&handler)) + return; + + status = ca_replace_printf_handler(handler); + + if (status != ECA_NORMAL) { + SvREFCNT_dec(printf_sub); + printf_sub = NULL; + croak(get_error_msg(status)); + } +} + + +/* CA::field_type($ca_ref) */ + +const char * CA_field_type(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + chtype t = ca_field_type(pch->chan); + if (t == TYPENOTCONN) + return "TYPENOTCONN"; + return dbr_type_to_text(t); +} + + +/* CA::element_count($ca_ref) */ + +int CA_element_count(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + return ca_element_count(pch->chan); +} + + +/* CA::name($ca_ref) */ + +const char * CA_name(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + return ca_name(pch->chan); +} + + +/* CA::state($ca_ref) */ + +const char * CA_state(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + static const char * const state_name[] = { + "never connected", "previously connected", "connected", "closed" + }; + return state_name[ca_state(pch->chan)]; +} + + +/* CA::is_connected($ca_ref) */ + +int CA_is_connected(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + return ca_state(pch->chan) == cs_conn; +} + + +/* CA::host_name($ca_ref) */ + +const char * CA_host_name(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + return ca_host_name(pch->chan); +} + + +/* CA::read_access($ca_ref) */ + +int CA_read_access(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + return ca_read_access(pch->chan); +} + + +/* CA::write_access($ca_ref) */ + +int CA_write_access(SV *ca_ref) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + return ca_write_access(pch->chan); +} + +/******************************************************************************/ + +MODULE = Cap5 PACKAGE = Cap5 + +MODULE = Cap5 PACKAGE = CA PREFIX = CA_ + +PROTOTYPES: DISABLE + +BOOT: + p5_ctx = Perl_get_context(); + + +SV * +CA_new (class, name, ...) + const char * class + const char * name + PREINIT: + I32* temp; + CODE: + temp = PL_markstack_ptr++; + RETVAL = CA_new(class, name); + PL_markstack_ptr = temp; + OUTPUT: + RETVAL + +void +CA_DESTROY (ca_ref) + SV * ca_ref + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_DESTROY(ca_ref); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_change_connection_event (ca_ref, sub) + SV * ca_ref + SV * sub + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_change_connection_event(ca_ref, sub); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_put (ca_ref, val, ...) + SV * ca_ref + SV * val + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_put(ca_ref, val); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_put_callback (ca_ref, sub, val, ...) + SV * ca_ref + SV * sub + SV * val + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_put_callback(ca_ref, sub, val); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_put_acks (ca_ref, sevr, ...) + SV * ca_ref + SV * sevr + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_put_acks(ca_ref, sevr); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_put_ackt (ca_ref, ack, ...) + SV * ca_ref + int ack + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_put_ackt(ca_ref, ack); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_get (ca_ref) + SV * ca_ref + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_get(ca_ref); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +SV * +CA_value (ca_ref) + SV * ca_ref + +void +CA_get_callback (ca_ref, sub, ...) + SV * ca_ref + SV * sub + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_get_callback(ca_ref, sub); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +SV * +CA_create_subscription (ca_ref, mask_str, sub, ...) + SV * ca_ref + const char * mask_str + SV * sub + PREINIT: + I32* temp; + CODE: + temp = PL_markstack_ptr++; + RETVAL = CA_create_subscription(ca_ref, mask_str, sub); + PL_markstack_ptr = temp; + OUTPUT: + RETVAL + +void +CA_clear_subscription (class, mon_ref) + const char * class + SV * mon_ref + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_clear_subscription(class, mon_ref); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_pend_io (class, timeout) + const char * class + double timeout + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_pend_io(class, timeout); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +int +CA_test_io (class) + const char * class + +void +CA_pend_event (class, timeout) + const char * class + double timeout + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_pend_event(class, timeout); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_poll (class) + const char * class + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_poll(class); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_flush_io (class) + const char * class + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_flush_io(class); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_add_exception_event (class, sub) + const char * class + SV * sub + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_add_exception_event(class, sub); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +void +CA_replace_printf_handler (class, sub) + const char * class + SV * sub + PREINIT: + I32* temp; + PPCODE: + temp = PL_markstack_ptr++; + CA_replace_printf_handler(class, sub); + if (PL_markstack_ptr != temp) { + /* truly void, because dXSARGS not invoked */ + PL_markstack_ptr = temp; + XSRETURN_EMPTY; /* return empty stack */ + } + /* must have used dXSARGS; list context implied */ + return; /* assume stack size is correct */ + +const char * +CA_field_type (ca_ref) + SV * ca_ref + +int +CA_element_count (ca_ref) + SV * ca_ref + +const char * +CA_name (ca_ref) + SV * ca_ref + +const char * +CA_state (ca_ref) + SV * ca_ref + +int +CA_is_connected (ca_ref) + SV * ca_ref + +const char * +CA_host_name (ca_ref) + SV * ca_ref + +int +CA_read_access (ca_ref) + SV * ca_ref + +int +CA_write_access (ca_ref) + SV * ca_ref + diff --git a/src/cap5/Makefile b/src/cap5/Makefile new file mode 100644 index 000000000..7573c8218 --- /dev/null +++ b/src/cap5/Makefile @@ -0,0 +1,53 @@ +#************************************************************************* +# Copyright (c) 2008 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. +#************************************************************************* + +TOP=../.. +include $(TOP)/configure/CONFIG + +EXPAND += cainfo.pl@ caput.pl@ caget.pl@ camonitor.pl@ CA.pm@ + +PERL_SCRIPTS += cainfo.pl +PERL_SCRIPTS += caput.pl +PERL_SCRIPTS += caget.pl +PERL_SCRIPTS += camonitor.pl +PERL_MODULES += CA.pm + +LOADABLE_LIBRARY_HOST = Cap5 + +ifneq (,$(findstring darwin,$(T_A))) + # Perl loadable libraries on Darwin have funny names + LOADABLE_SHRLIB_PREFIX = + LOADABLE_SHRLIB_SUFFIX = .bundle +endif + +Cap5_SRCS = Cap5.xs +Cap5_LIBS = ca Com +Cap5_INCLUDES = -I $(shell $(PERL) ../perlConfig.pl archlib)/CORE +Cap5_CFLAGS = $(shell $(PERL) ../perlConfig.pl ccflags) + +ifeq ($(findstring Host,$(VALID_BUILDS)),Host) + # Can only create docs in Host build + HTMLS_DIR = . + HTMLS = CA.html +endif + +include $(TOP)/configure/RULES + +ifdef T_A + TYPEMAP = $(shell $(PERL) ../perlConfig.pl privlib)/ExtUtils/typemap + + %.c: ../%.xs + $(RM) $@ $@_new + xsubpp -typemap $(TYPEMAP) $< > $@_new && $(MV) $@_new $@ + + %.html: %.pm + $(RM) $@ + podchecker $< && pod2html --infile=$< --outfile=$@ + + clean:: + $(RM) Cap5.c +endif diff --git a/src/cap5/caget.pl@ b/src/cap5/caget.pl@ new file mode 100644 index 000000000..98b529d2f --- /dev/null +++ b/src/cap5/caget.pl@ @@ -0,0 +1,154 @@ +#!/usr/bin/perl + +use strict; +use lib '@TOP@/lib/perl'; +use Getopt::Std; +use CA; + +our ($opt_0, $opt_a, $opt_C, $opt_d, $opt_e, $opt_f, $opt_g, $opt_h, $opt_n); +our ($opt_s, $opt_t); +our $opt_w = 1; + +$Getopt::Std::OUTPUT_HELP_VERSION = 1; + +HELP_MESSAGE() unless getopts('0:aC:d:e:f:g:hnstw:'); +HELP_MESSAGE() if $opt_h; + +$opt_d = "DBR_$opt_d" if $opt_d && $opt_d !~ m/^DBR_/; + +die "No pv name specified. ('caget -h' for help.)\n" + unless @ARGV; + +my @chans = map { CA->new($_); } @ARGV; + +eval { CA->pend_io($opt_w); }; +if ($@) { + if ($@ =~ m/^ECA_TIMEOUT/) { + my $err = (@chans > 1) ? 'some PV(s)' : "'" . $chans[0]->name . "'"; + print "Channel connect timed out: $err not found.\n"; + @chans = grep { $_->is_connected } @chans; + } else { + die $@; + } +} + +my %rtype; + +map { + my $type; + if ($opt_d) { + $type = $opt_d; + } else { + $type = $_->field_type; + $type = 'DBR_STRING' + if $opt_s && $type =~ m/ ^DBR_FLOAT$ | ^DBR_DOUBLE$ /x; + $type = 'DBR_LONG' + if $opt_n && $type eq 'DBR_ENUM'; + $type =~ s/^DBR_/DBR_TIME_/ + if $opt_a; + } + $rtype{$_} = $type; + my $count = $_->element_count; + $count = +$opt_C if $opt_C && $opt_C <= $count; + $_->get_callback(\&get_callback, $type, $count); +} @chans; + +my $incomplete = @chans; +CA->pend_event(0.1) while $incomplete; + + +sub get_callback { + my ($chan, $status, $data) = @_; + die $status if $status; + display($chan, $rtype{$chan}, $data); + $incomplete--; +} + +sub format_number { + my ($data, $type) = @_; + if ($type =~ m/_DOUBLE$/) { + return sprintf "%.${opt_e}e", $data if $opt_e; + return sprintf "%.${opt_f}f", $data if $opt_f; + return sprintf "%.${opt_g}g", $data if $opt_g; + } + if ($type =~ m/_LONG$/) { + return sprintf "%lx", $data if $opt_0 eq 'x'; + return sprintf "%lo", $data if $opt_0 eq 'o'; + if ($opt_0 eq 'b') { + my $bin = unpack "B*", pack "l", $data; + $bin =~ s/^0*//; + return $bin; + } + } + return $data; +} + +sub display { + my ($chan, $type, $data) = @_; + if (ref $data eq 'ARRAY') { + display($chan, $type, join(' ', scalar @{$data}, @{$data})); + } elsif (ref $data eq 'HASH') { + $type = $data->{TYPE}; # Can differ from request + my $value = $data->{value}; + if (ref $value eq 'ARRAY') { + $value = join(' ', $data->{COUNT}, + map { format_number($_, $type); } @{$value}); + } else { + $value = format_number($value, $type); + } + my $stamp; + if (exists $data->{stamp}) { + my @t = localtime $data->{stamp}; + splice @t, 6; + $t[5] += 1900; + $t[0] += $data->{stamp_fraction}; + $stamp = sprintf "%4d-%02d-%02d %02d:%02d:%09.6f", reverse @t; + } + printf "%-30s %s %s %s %s\n", $chan->name, + $stamp, $value, $data->{status}, $data->{severity}; + } else { + my $value = format_number($data, $type); + if ($opt_t) { + print "$value\n"; + } else { + printf "%-30s %s\n", $chan->name, $value; + } + } +} + +sub HELP_MESSAGE { + print STDERR "\nUsage: caget [options] ...\n", + "\n", + " -h: Help: Print this message\n", + "Channel Access options:\n", + " -w : Wait time, specifies longer CA timeout, default is $opt_w second\n", + "Format options:\n", + " -t: Terse mode - print only value, without name\n", + " -a: Wide mode \"name timestamp value stat sevr\" (read PVs as DBR_TIME_xxx)\n", + " -d : Request specific dbr type from one of the following:\n", + " DBR_STRING DBR_LONG DBR_DOUBLE\n", + " DBR_STS_STRING DBR_STS_LONG DBR_STS_DOUBLE\n", + " DBR_TIME_STRING DBR_TIME_LONG DBR_TIME_DOUBLE\n", + " DBR_GR_STRING DBR_GR_LONG DBR_GR_DOUBLE DBR_GR_ENUM\n", + " DBR_CTRL_STRING DBR_CTRL_LONG DBR_CTRL_DOUBLE DBR_CTRL_ENUM\n", + " DBR_CLASS_NAME DBR_STSACK_STRING\n", + "Arrays: Value format: print number of values, then list of values\n", + " Default: Print all values\n", + " -C : Print first elements of an array\n", + "Enum format:\n", + " -n: Print DBF_ENUM value as number (default is enum string)\n", + "Floating point type format:\n", + " Default: Use %g format\n", + " -e : Use %e format, with a precision of digits\n", + " -f : Use %f format, with a precision of digits\n", + " -g : Use %g format, with a precision of digits\n", + " -s: Get value as string (may honour server-side precision)\n", + "Integer number format:\n", + " Default: Print as decimal number\n", + " -0x: Print as hex number\n", + " -0o: Print as octal number\n", + " -0b: Print as binary number\n", + "\n"; + exit 1; +} + diff --git a/src/cap5/cainfo.pl@ b/src/cap5/cainfo.pl@ new file mode 100644 index 000000000..2362ef70b --- /dev/null +++ b/src/cap5/cainfo.pl@ @@ -0,0 +1,63 @@ +#!/usr/bin/perl + +use strict; +use lib '@TOP@/lib/perl'; +use Getopt::Std; +use CA; + +our $opt_w = 1; +our $opt_h; + +$Getopt::Std::OUTPUT_HELP_VERSION = 1; + +HELP_MESSAGE() unless getopts('hw:'); +HELP_MESSAGE() if $opt_h; + +die "No pv name specified. ('cainfo -h' for help.)\n" + unless @ARGV; + +my @chans = map { CA->new($_); } @ARGV; + +eval { + CA->pend_io($opt_w); +}; +if ($@) { + if ($@ =~ m/^ECA_TIMEOUT/) { + my $err = (@chans > 1) ? 'some PV(s)' : "'" . $chans[0]->name . "'"; + print "Channel connect timed out: $err not found.\n"; + } else { + die $@; + } +} + +map { display($_); } @chans; + +undef @chans; + + +sub display { + my $chan = shift; + + printf "%s\n", $chan->name; + printf " State: %s\n", $chan->state; + printf " Host: %s\n", $chan->host_name; + + my @access = ('no ', ''); + printf " Access: %sread, %swrite\n", + $access[$chan->read_access], $access[$chan->write_access]; + + printf " Data type: %s\n", $chan->field_type; + printf " Element count: %d\n", $chan->element_count; +} + +sub HELP_MESSAGE { + print STDERR "\nUsage: cainfo [options] ...\n", + "\n", + " -h: Help: Print this message\n", + "Channel Access options:\n", + " -w : Wait time, specifies CA timeout, default is $opt_w second\n", + "\n", + "Example: cainfo my_channel another_channel\n", + "\n"; + exit 1; +} diff --git a/src/cap5/camonitor.pl@ b/src/cap5/camonitor.pl@ new file mode 100644 index 000000000..f8fe2cefb --- /dev/null +++ b/src/cap5/camonitor.pl@ @@ -0,0 +1,137 @@ +#!/usr/bin/perl + +use strict; +use lib '@TOP@/lib/perl'; +use Getopt::Std; +use CA; + +our ($opt_0, $opt_C, $opt_e, $opt_f, $opt_g, $opt_h, $opt_n, $opt_s); +our $opt_w = 1; +our $opt_m = 'va'; + +$Getopt::Std::OUTPUT_HELP_VERSION = 1; + +HELP_MESSAGE() unless getopts('0:C:e:f:g:hm:nsw:'); +HELP_MESSAGE() if $opt_h; + +die "No pv name specified. ('camonitor -h' for help.)\n" + unless @ARGV; + +my %monitors; +my @chans = map { CA->new($_, \&conn_callback); } @ARGV; + +CA->pend_event($opt_w); +map { + printf "%-30s %s\n", $_->name, '*** Not connected (PV not found)' + unless $monitors{$_}; +} @chans; +CA->pend_event(0); + + +sub conn_callback { + my ($chan, $up) = @_; + if ($up && ! $monitors{$chan}) { + my $type = $chan->field_type; + $type = 'DBR_STRING' + if $opt_s && $type =~ m/ DBR_DOUBLE | DBR_FLOAT /x; + $type = 'DBR_LONG' + if $opt_n && $type eq 'DBR_ENUM'; + $type =~ s/^DBR_/DBR_TIME_/; + + my $count = $chan->element_count; + $count = +$opt_C if $opt_C && $opt_C <= $count; + + $monitors{$chan} = + $chan->create_subscription($opt_m, \&mon_callback, $type, $count); + } +} + +sub mon_callback { + my ($chan, $status, $data) = @_; + if ($status) { + printf "%-30s %s\n", $chan->name, $status; + } else { + display($chan, $data); + } +} + +sub format_number { + my ($data, $type) = @_; + if ($type =~ m/_DOUBLE$/) { + return sprintf "%.${opt_e}e", $data if $opt_e; + return sprintf "%.${opt_f}f", $data if $opt_f; + return sprintf "%.${opt_g}g", $data if $opt_g; + } + if ($type =~ m/_LONG$/) { + return sprintf "%lx", $data if $opt_0 eq 'x'; + return sprintf "%lo", $data if $opt_0 eq 'o'; + if ($opt_0 eq 'b') { + my $bin = unpack "B*", pack "l", $data; + $bin =~ s/^0*//; + return $bin; + } + } + return $data; +} + +sub display { + my ($chan, $data) = @_; + die "Internal error" + unless ref $data eq 'HASH'; + + my $type = $data->{TYPE}; + my $value = $data->{value}; + if (ref $value eq 'ARRAY') { + $value = join(' ', $data->{COUNT}, + map { format_number($_, $type); } @{$value}); + } else { + $value = format_number($value, $type); + } + my $stamp; + if (exists $data->{stamp}) { + my @t = localtime $data->{stamp}; + splice @t, 6; + $t[5] += 1900; + $t[0] += $data->{stamp_fraction}; + $stamp = sprintf "%4d-%02d-%02d %02d:%02d:%09.6f", reverse @t; + } + printf "%-30s %s %s %s %s\n", $chan->name, + $stamp, $value, $data->{status}, $data->{severity}; +} + +sub HELP_MESSAGE { + print STDERR "\nUsage: camonitor [options] ...\n", + "\n", + " -h: Help: Print this message\n", + "Channel Access options:\n", + " -w : Wait time, specifies longer CA timeout, default is $opt_w second\n", + " -m : Specify CA event mask to use, with being any combination of\n", + " 'v' (value), 'a' (alarm), 'l' (log). Default: '$opt_m'\n", + "Timestamps:\n", + " Default: Print absolute timestamps (as reported by CA)\n", + " -r: Relative timestamps (time elapsed since start of program)\n", + " -i: Incremental timestamps (time elapsed since last update)\n", + " -I: Incremental timestamps (time elapsed since last update for this channel)\n", + "Enum format:\n", + " -n: Print DBF_ENUM values as number (default are enum string values)\n", + "Arrays: Value format: print number of values, then list of values\n", + " Default: Print all values\n", + " -C : Print first elements of an array\n", + "Floating point type format:\n", + " Default: Use %g format\n", + " -e : Use %e format, with a precision of digits\n", + " -f : Use %f format, with a precision of digits\n", + " -g : Use %g format, with a precision of digits\n", + " -s: Get value as string (may honour server-side precision)\n", + "Integer number format:\n", + " Default: Print as decimal number\n", + " -0x: Print as hex number\n", + " -0o: Print as octal number\n", + " -0b: Print as binary number\n", + "\n", + "Example: camonitor -f8 my_channel another_channel\n", + " (doubles are printed as %f with 8 decimal digits)\n", + "\n"; + exit 1; +} + diff --git a/src/cap5/caput.pl@ b/src/cap5/caput.pl@ new file mode 100644 index 000000000..84d53ee23 --- /dev/null +++ b/src/cap5/caput.pl@ @@ -0,0 +1,181 @@ +#!/usr/bin/perl + +use strict; +use lib '@TOP@/lib/perl'; +use Getopt::Std; +use CA; + +our ($opt_0, $opt_c, $opt_e, $opt_f, $opt_g, $opt_h, $opt_l, + $opt_n, $opt_s, $opt_t); +our $opt_w = 1; + +$Getopt::Std::OUTPUT_HELP_VERSION = 1; + +HELP_MESSAGE() unless getopts('achlnstw:'); +HELP_MESSAGE() if $opt_h; + +die "No pv name specified. ('caput -h' for help.)\n" + unless @ARGV; +my $pv = shift; + +die "No value specified. ('caput -h' for help.)\n" + unless @ARGV; + +my $chan = CA->new($pv); +eval { + CA->pend_io($opt_w); +}; +if ($@) { + if ($@ =~ m/^ECA_TIMEOUT/) { + print "Channel connect timed out: '$pv' not found.\n"; + exit 2; + } else { + die $@; + } +} + +die "Write access denied for '$pv'.\n" unless $chan->write_access; + +my $n = $chan->element_count(); +die "Too many values given, '$pv' limit is $n\n" + unless $n >= @ARGV; + +my $type = $chan->field_type; +$type = 'DBR_STRING' + if $opt_s && $type =~ m/ ^DBR_ENUM$ | ^DBR_FLOAT$ | ^DBR_DOUBLE$ /x; +$type = 'DBR_LONG' + if $opt_n && $type eq 'DBR_ENUM'; +$type =~ s/^DBR_/DBR_TIME_/ + if $opt_l; + +my @values; +if ($type !~ m/ ^DBR_STRING$ | ^DBR_ENUM$ /x) { + # Make @ARGV strings numeric + @values = map { +$_; } @ARGV; +} else { + # Use strings + @values = @ARGV; +} + +my $done = 0; +if ($opt_t) { + do_put(); +} else { + $chan->get_callback(\&old_callback, $type); +} +CA->pend_event(0.1) until $done; + + +sub old_callback { + my ($chan, $status, $data) = @_; + die $status if $status; + display($chan, $type, $data, 'Old'); + do_put(); +} + +sub do_put { + if ($opt_c) { + $chan->put_callback(\&put_callback, @values); + } else { + $chan->put(@values); + $chan->get_callback(\&new_callback, $type); + } +} + +sub put_callback { + my ($chan, $status) = @_; + die $status if $status; + $chan->get_callback(\&new_callback, $type); +} + +sub new_callback { + my ($chan, $status, $data) = @_; + die $status if $status; + display($chan, $type, $data, 'New'); + $done = 1; +} + +sub format_number { + my ($data, $type) = @_; + if ($type =~ m/_DOUBLE$/) { + return sprintf "%.${opt_e}e", $data if $opt_e; + return sprintf "%.${opt_f}f", $data if $opt_f; + return sprintf "%.${opt_g}g", $data if $opt_g; + } + if ($type =~ m/_LONG$/) { + return sprintf "%lx", $data if $opt_0 eq 'x'; + return sprintf "%lo", $data if $opt_0 eq 'o'; + if ($opt_0 eq 'b') { + my $bin = unpack "B*", pack "l", $data; + $bin =~ s/^0*//; + return $bin; + } + } + return $data; +} + +sub display { + my ($chan, $type, $data, $prefix) = @_; + if (ref $data eq 'ARRAY') { + display($chan, $type, join(' ', @{$data}), $prefix); + } elsif (ref $data eq 'HASH') { + $type = $data->{TYPE}; # Can differ from request + my $value = $data->{value}; + if (ref $value eq 'ARRAY') { + $value = join(' ', map { format_number($_, $type); } @{$value}); + } else { + $value = format_number($value, $type); + } + my $stamp; + if (exists $data->{stamp}) { + my @t = localtime $data->{stamp}; + splice @t, 6; + $t[5] += 1900; + $t[0] += $data->{stamp_fraction}; + $stamp = sprintf "%4d-%02d-%02d %02d:%02d:%09.6f", reverse @t; + } + printf "%-30s %s %s %s %s\n", $chan->name, + $stamp, $value, $data->{status}, $data->{severity}; + } else { + my $value = format_number($data, $type); + if ($opt_t) { + print "$value\n"; + } else { + printf "$prefix : %-30s %s\n", $chan->name, $value; + } + } +} + +sub HELP_MESSAGE { + print STDERR "\nUsage: caput [options] ...\n", + "\n", + " -h: Help: Print this message\n", + "Channel Access options:\n", + " -w : Wait time, specifies longer CA timeout, default is $opt_w second\n", + " -c: Use put_callback to wait for completion\n", + "Format options:\n", + " -t: Terse mode - print only sucessfully written value, without name\n", + " -l: Long mode \"name timestamp value stat sevr\" (read PVs as DBR_TIME_xxx)\n", + "Enum format:\n", + " Default: Auto - try value as ENUM string, then as index number\n", + " -n: Force interpretation of values as numbers\n", + " -s: Force interpretation of values as strings\n", + "Floating point type format:\n", + " Default: Use %g format\n", + " -e : Use %e format, with a precision of digits\n", + " -f : Use %f format, with a precision of digits\n", + " -g : Use %g format, with a precision of digits\n", + " -s: Get value as string (may honour server-side precision)\n", + "Integer number format:\n", + " Default: Print as decimal number\n", + " -0x: Print as hex number\n", + " -0o: Print as octal number\n", + " -0b: Print as binary number\n", + "\n", + "Examples:\n", + " caput my_channel 1.2\n", + " caput my_waveform 1.2 2.4 3.6 4.8 6.0\n", + "\n"; + exit 1; +} + diff --git a/src/cap5/perlConfig.pl b/src/cap5/perlConfig.pl new file mode 100644 index 000000000..11a524595 --- /dev/null +++ b/src/cap5/perlConfig.pl @@ -0,0 +1,9 @@ +#!/usr/bin/perl + +# This script is used to extract information about the Perl build +# configuration, so the EPICS build system uses the same settings. + +use Config; + +my $arg = shift; +print $Config{$arg};