diff --git a/src/ca/client/perl/CA.pm b/src/ca/client/perl/CA.pm index 48297162c..4b993d64d 100644 --- a/src/ca/client/perl/CA.pm +++ b/src/ca/client/perl/CA.pm @@ -4,7 +4,7 @@ use strict; use warnings; -my $version = '0.5'; +my $version = '0.6'; package CA; @@ -316,6 +316,19 @@ 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. + +=item change_access_rights_event( I ) + +This method replaces, adds or cancels an access rights handler subroutine for +the channel, which will be called if the client's right to read from or write +to the channel changes. If I is C any existing handler is removed, +otherwise the new subroutine will be used for all future rights change events +on this channel. + +The arguments passed to I are the channel object and a pair of scalar +values for read and write permissions respectively, that are true when the +access is permitted, false when it is not. + =back @@ -636,9 +649,9 @@ not follow this pattern, but are still printable strings. =over -=item [1] R3.14 Channel Access Reference Manual by Jeffrey O. Hill +=item [1] R3.15 Channel Access Reference Manual by Jeffrey O. Hill -L +L =back diff --git a/src/ca/client/perl/Cap5.xs b/src/ca/client/perl/Cap5.xs index e66a2aa06..0bb3f7d28 100644 --- a/src/ca/client/perl/Cap5.xs +++ b/src/ca/client/perl/Cap5.xs @@ -519,6 +519,46 @@ void CA_change_connection_event(SV *ca_ref, SV *sub) { } } +/* CA::replace_access_rights_event($ca_ref, \$sub) */ + +static +void rights_handler(struct access_rights_handler_args arha) { + CA_channel *pch = ca_puser(arha.chid); + + PERL_SET_CONTEXT(p5_ctx); + { + dSP; + + SvSetSV(ERRSV, &PL_sv_undef); + + PUSHMARK(SP); + XPUSHs(pch->chan_ref); + XPUSHs(arha.ar.read_access ? &PL_sv_yes : &PL_sv_no); + XPUSHs(arha.ar.write_access ? &PL_sv_yes : &PL_sv_no); + PUTBACK; + + call_sv(pch->rights_sub, G_EVAL | G_VOID | G_DISCARD | G_KEEPERR); + + if (SvTRUE(ERRSV)) + croak(NULL); + } +} + +void CA_replace_access_rights_event(SV *ca_ref, SV *sub) { + CA_channel *pch = (CA_channel *)SvIV(SvRV(ca_ref)); + caCh *handler = &rights_handler; + int status; + + if (! replace_handler(sub, &pch->rights_sub, (long *)&handler)) + return; + + status = ca_change_connection_event(pch->chan, handler); + + if (status != ECA_NORMAL) { + croak("%s", get_error_msg(status)); + } +} + /* CA::put($ca_ref, @values) */ @@ -1265,6 +1305,11 @@ CA_change_connection_event (ca_ref, sub) SV * ca_ref SV * sub +void +CA_replace_access_rights_event (ca_ref, sub) + SV * ca_ref + SV * sub + void CA_put (ca_ref, val, ...) SV * ca_ref