Skip to content
Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 171 lines (135 sloc) 4.37 KB
#!/usr/bin/perl -w
=head1 NAME
xpl-sender - Perl script for an xPL message sender application
=head1 SYNOPSIS
xpl-sender [flags] [options] -m <msg.type> -c <schema> [param=value ... ]
where valid flags are:
-h - show this help text
-v - verbose mode
and valid options are (default shown in brackets):
-i if0 - the interface for xPL messages
(first non-loopback or loopback)
-m xpl-type - the xPL message type (xpl-cmnd)
-c class.type - the schema type
-s source - the source type
-t target - the target type
-w time - time to wait for a response (0 - don't wait)
# send the text 'Boo' to all devices supporting osd.basic
xpl-sender -c osd.basic command=clear text=Boo
# send a heartbeat request and wait 10 seconds for any responses
xpl-sender -c hbeat.request -w 10
# something to go in /etc/apcupsd/mainsback perhaps:
xpl-sender -m xpl-trig -c ups.basic status=mains event=onmains
# something to go in /etc/apcupsd/onbattery perhaps:
xpl-sender -m xpl-trig -c ups.basic status=battery event=onbattery
=head1 DESCRIPTION
This script is an xPL client that sends an xPL message based on
command line arguments.
=cut
use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;
use Time::HiRes;
use xPL::Client;
$|=1; # autoflush helps debugging
BEGIN {
# get some help with defaults and helpful error messages
$ENV{XPL_MESSAGE_VALIDATE} = 1;
}
my %args = ( vendor_id => 'bnz', device_id => 'sender', );
my %opt = ();
my $verbose;
my $interface;
my $help;
my $man;
my $message_type = 'xpl-cmnd';
my $schema;
my $source;
my $target;
my $wait;
GetOptions('verbose+' => \$verbose,
'interface=s' => \$interface,
'define=s' => \%opt,
'help|?|h' => \$help,
'man' => \$man,
'message_type|m=s' => \$message_type,
'class=s' => \$schema,
'schema=s' => \$schema,
'source=s' => \$source,
'target=s' => \$target,
'wait=i' => \$wait,
) or pod2usage(2);
pod2usage(1) if ($help);
pod2usage(-exitstatus => 0, -verbose => 2) if ($man);
$args{'interface'} = $interface if ($interface);
$args{'verbose'} = $verbose if ($verbose);
my %msg_args = ();
defined $schema or
pod2usage(-message => q{Requires '--schema' schema parameter},
-exitstatus => 1);
$msg_args{'-m'} = $message_type if (defined $message_type);
$msg_args{'-c'} = $schema if (defined $schema);
$msg_args{'-s'} = $source if (defined $source);
$msg_args{'-t'} = $target if (defined $target);
# Create an xPL Client object
my $xpl = xPL::Client->new(%args, %opt) or die "Failed to create xPL::Client\n";
my $start_time;
unless ($wait) {
$xpl->send_from_arg_list(%msg_args, @ARGV);
exit;
}
$xpl->add_event_callback(id => 'trigger_send', event => 'hub_found',
callback => \&xpl_hub_response);
$xpl->main_loop();
sub xpl_hub_response {
my %p = @_;
my $msg = $p{message};
print STDERR "Sending\n" if ($verbose);
xpl_send();
}
sub xpl_send {
my $c = $schema;
$c =~ s/\..*$//;
$xpl->send_from_arg_list(%msg_args, @ARGV);
$start_time = Time::HiRes::time;
$xpl->add_xpl_callback(id => 'wait_for_response',
filter =>
{
schema => $c,
},
callback => \&xpl_response);
$xpl->add_timer(id => 'timeout', timeout => $wait, callback => \&give_up);
return;
}
sub xpl_response {
my %p = @_;
my $msg = $p{message};
my $rtt = (Time::HiRes::time-$start_time);
if ($verbose) {
print $msg->string;
}
if ($msg->schema =~ /^ping\./) {
$rtt -= $msg->field('delay') || 0;
my $time = $msg->field('checktime');
$time = defined $time ? (sprintf '%.6f', $time) : 'timeout';
printf("ping.response: rtt=%.6f checktime=%s %s\n",
$rtt, $time, $msg->source);
} elsif (!$verbose) {
print $msg->summary, "\n";
}
}
sub give_up {
exit 1;
}
=head1 SEE ALSO
xPL::Client(3), xPL::Listener(3)
Project website: http://www.xpl-perl.org.uk/
=head1 AUTHOR
Mark Hindess, E<lt>soft-xpl-perl@temporalanomaly.comE<gt>
=head1 COPYRIGHT
Copyright (C) 2005, 2009 by Mark Hindess
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.7 or,
at your option, any later version of Perl 5 you may have available.
=cut
You can’t perform that action at this time.