|
@@ -1,431 +0,0 @@
|
|
|
-#!/usr/bin/perl -w
|
|
|
|
|
-
|
|
|
|
|
-# $Id$
|
|
|
|
|
-
|
|
|
|
|
-# $Log$
|
|
|
|
|
-# Revision 1.1 2002/11/29 12:02:00 stanleyhopcroft
|
|
|
|
|
-# New plugin to check the ICA browse service (used by Citrix Metaframe servers) from
|
|
|
|
|
-# Ed Rolison and Tom De Blende.
|
|
|
|
|
-#
|
|
|
|
|
-
|
|
|
|
|
-# Ed Rolison 15/06/02
|
|
|
|
|
-# ed@nightstalker.net
|
|
|
|
|
-# If it doesn't work, please let me know, I've only had access to my
|
|
|
|
|
-# environment so I'm not 100% sure.
|
|
|
|
|
-#
|
|
|
|
|
-# If you want to mess around with this script, then please feel free
|
|
|
|
|
-# to do so.
|
|
|
|
|
-# However, if you add anything 'funky' then I'd really appreciate
|
|
|
|
|
-# hearing about it.
|
|
|
|
|
-#
|
|
|
|
|
-# Oh, and if you do ever make huge amounts of money out of it, cut me
|
|
|
|
|
-# in :)
|
|
|
|
|
-
|
|
|
|
|
-use strict ;
|
|
|
|
|
-
|
|
|
|
|
-use IO::Socket;
|
|
|
|
|
-use IO::Select;
|
|
|
|
|
-use FileHandle;
|
|
|
|
|
-use Getopt::Long ;
|
|
|
|
|
-
|
|
|
|
|
-use vars qw($opt_H $opt_B $opt_W $opt_T $debug @citrix_servers $crit_pub_apps $warn_pub_apps $long_list);
|
|
|
|
|
-use utils qw(%ERRORS &print_revision &support &usage);
|
|
|
|
|
-
|
|
|
|
|
-my $PROGNAME = 'check_citrix' ;
|
|
|
|
|
-
|
|
|
|
|
-sub print_help ();
|
|
|
|
|
-sub print_usage ();
|
|
|
|
|
-sub help ();
|
|
|
|
|
-sub version ();
|
|
|
|
|
-
|
|
|
|
|
-delete @ENV{'PATH', 'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
|
|
|
|
|
-
|
|
|
|
|
-# You might have to change this...
|
|
|
|
|
-
|
|
|
|
|
-use constant PACKET_TIMEOUT => 1;
|
|
|
|
|
- # Number of seconds to wait for further UDP packets
|
|
|
|
|
-use constant TEST_COUNT => 2;
|
|
|
|
|
- # Number of datagrams sent without reply
|
|
|
|
|
-use constant BUFFER_SIZE => 1500;
|
|
|
|
|
- # buffer size used for 'recv' calls.
|
|
|
|
|
-use constant LONG_LIST => 0 ;
|
|
|
|
|
- # this is for if you have many published applications.
|
|
|
|
|
- # if you set it, it won't do any harm, but may slow the test
|
|
|
|
|
- # down a little. (Since it does a 'recv' twice instead of
|
|
|
|
|
- # once and therefore may have to wait for a timeout).
|
|
|
|
|
-use constant ICA_PORT => 1604;
|
|
|
|
|
- # what port ICA runs on. Unlikely to change.
|
|
|
|
|
-
|
|
|
|
|
-# End user config.
|
|
|
|
|
-
|
|
|
|
|
-Getopt::Long::Configure('bundling', 'no_ignore_case');
|
|
|
|
|
-GetOptions
|
|
|
|
|
- ("V|version" => \&version,
|
|
|
|
|
- "h|help" => \&help,
|
|
|
|
|
- "d|debug" => \$debug,
|
|
|
|
|
- "B|broadcast_addr:s" => \$opt_B,
|
|
|
|
|
- "C|citrix_servers:s" => \@citrix_servers,
|
|
|
|
|
- "L|long_list" => \$long_list,
|
|
|
|
|
- "P|crit_pub_apps:s" => \$crit_pub_apps,
|
|
|
|
|
- "T|Packet_timeout:i" => \$opt_T,
|
|
|
|
|
- "W|warn_pub_apps:s" => \$warn_pub_apps,
|
|
|
|
|
-) ;
|
|
|
|
|
-
|
|
|
|
|
-# configuration section
|
|
|
|
|
-
|
|
|
|
|
-my $broadcast_addr = $1 if $opt_B and $opt_B =~ m#(\d+\.\d+\.\d+\.\d+)# ;
|
|
|
|
|
-usage("Invalid broadcast address: $opt_B\n") if $opt_B and not defined($broadcast_addr) ;
|
|
|
|
|
-
|
|
|
|
|
-usage("You must provide either the names of citrix servers or the broadcast address of the subnet containing them\n")
|
|
|
|
|
- unless (@citrix_servers or $broadcast_addr) ;
|
|
|
|
|
-
|
|
|
|
|
-my @target = defined $broadcast_addr ? ($broadcast_addr) : @citrix_servers ;
|
|
|
|
|
-
|
|
|
|
|
-usage("You must provide the names of the published applications that the Citrix browser should be advertising\n")
|
|
|
|
|
- unless $crit_pub_apps or $warn_pub_apps ;
|
|
|
|
|
-
|
|
|
|
|
-my $Timeout = $opt_T if defined $opt_T ;
|
|
|
|
|
-$Timeout = PACKET_TIMEOUT unless defined $Timeout ;
|
|
|
|
|
-$long_list = LONG_LIST unless defined $long_list ;
|
|
|
|
|
-
|
|
|
|
|
-my @crit_pub_apps = $crit_pub_apps ? split(/,/, $crit_pub_apps) : () ;
|
|
|
|
|
-my @warn_pub_apps = $warn_pub_apps ? split(/,/, $warn_pub_apps) : () ;
|
|
|
|
|
-
|
|
|
|
|
-# definitions of query strings. Change at your own risk :)
|
|
|
|
|
-# this info was gathered with tcpdump whilst trying to use an ICA client,
|
|
|
|
|
-# so I'm not 100% sure of what each value is.
|
|
|
|
|
-
|
|
|
|
|
-my @bcast_helo = &tethereal2list(<<'End_of_Tethereal_trace', '1e') ;
|
|
|
|
|
-0020 ff ff 04 d6 06 44 00 26 4a 76 1e 00 01 30 02 fd .....D.&Jv...0..
|
|
|
|
|
-0030 a8 e3 00 02 f5 95 9f f5 30 07 00 00 00 00 00 00 ........0.......
|
|
|
|
|
-0040 00 00 00 00 00 00 01 00
|
|
|
|
|
-End_of_Tethereal_trace
|
|
|
|
|
-
|
|
|
|
|
-my @bcast_query_app = &tethereal2list(<<'End_of_Tethereal_trace', '24') ;
|
|
|
|
|
-0020 64 17 04 50 06 44 00 2c 85 6a 24 00 01 32 02 fd d..P.D.,.j$..2..
|
|
|
|
|
-0030 a8 e3 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
|
|
|
|
|
-0040 00 00 00 00 00 00 21 00 02 00 00 00 00 00 ......!......
|
|
|
|
|
-End_of_Tethereal_trace
|
|
|
|
|
-
|
|
|
|
|
-my @direct_helo = &tethereal2list(<<'End_of_Tethereal_trace', '20') ;
|
|
|
|
|
-0020 64 17 05 0f 06 44 00 28 ab b5 20 00 01 30 02 fd d....D.(.. ..0..
|
|
|
|
|
-0030 a8 e3 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
|
|
|
|
|
-0040 00 00 00 00 00 00 00 00 00 00
|
|
|
|
|
-End_of_Tethereal_trace
|
|
|
|
|
-
|
|
|
|
|
-my @direct_query_app = &tethereal2list(<<'End_of_Tethereal_trace', '2c') ;
|
|
|
|
|
-0020 64 17 05 10 06 44 00 34 7a 9a 2c 00 02 32 02 fd d....D.4z.,..2..
|
|
|
|
|
-0030 a8 e3 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................
|
|
|
|
|
-0040 00 00 00 00 00 00 21 00 02 00 01 00 00 00 00 00 ......!.........
|
|
|
|
|
-0050 00 00 00 00 00 00
|
|
|
|
|
-End_of_Tethereal_trace
|
|
|
|
|
-
|
|
|
|
|
-my $Udp = IO::Socket::INET->new( Proto => 'udp' ) || die "Socket failure: $!";
|
|
|
|
|
-
|
|
|
|
|
-# select is here to allow us to set timeouts on the connections. Otherwise they
|
|
|
|
|
-# just 'stop' until a server appears.
|
|
|
|
|
-
|
|
|
|
|
-my $select = IO::Select->new($Udp) || die "Select failure: $!";
|
|
|
|
|
-
|
|
|
|
|
-# helo needs to be broadcast, but query does not.
|
|
|
|
|
-
|
|
|
|
|
-$Udp->sockopt(SO_BROADCAST, 1 );
|
|
|
|
|
-$Udp->autoflush(1);
|
|
|
|
|
-
|
|
|
|
|
-my ($remote_host, $buff, $buff2, $raddr, $rport, $rhost, @remote_response);
|
|
|
|
|
-my (@query_message, $send_addr, $this_test) ;
|
|
|
|
|
-
|
|
|
|
|
-$buff = $buff2 = '';
|
|
|
|
|
-$this_test = 0;
|
|
|
|
|
-
|
|
|
|
|
-# If there is no response to the first helo packet it will be resent
|
|
|
|
|
-# up to TEST_COUNT (see at the top).
|
|
|
|
|
-
|
|
|
|
|
-while ( ++$this_test <= TEST_COUNT && !$buff ) {
|
|
|
|
|
-
|
|
|
|
|
- print "Sending helo datagram. datagram number: ", $this_test, "\n" if $debug ;
|
|
|
|
|
-
|
|
|
|
|
- # if we have multiple targets, we probe each of them until we get a
|
|
|
|
|
- # response...
|
|
|
|
|
-
|
|
|
|
|
- foreach my $destination (@target) {
|
|
|
|
|
- @query_message = ( $broadcast_addr ? @bcast_helo : @direct_helo) ;
|
|
|
|
|
- print "Querying $destination for master browser\n" if $debug ;
|
|
|
|
|
- $send_addr = sockaddr_in(ICA_PORT, inet_aton($destination) );
|
|
|
|
|
- &dump(pack('C*', @query_message)) if $debug ;
|
|
|
|
|
- $Udp->send( pack('C*', @query_message), 0, $send_addr );
|
|
|
|
|
- if ( $select->can_read($Timeout) ) {
|
|
|
|
|
- $remote_host = $Udp->recv($buff, BUFFER_SIZE, 0 );
|
|
|
|
|
- }
|
|
|
|
|
-
|
|
|
|
|
- last if $buff ;
|
|
|
|
|
- sleep 1 ;
|
|
|
|
|
-
|
|
|
|
|
- } # foreach destination
|
|
|
|
|
-} # while loop
|
|
|
|
|
-
|
|
|
|
|
-# ok we've looped several times, looking for a response. If we don't have one
|
|
|
|
|
-# yet, we simply mark the whole lot as being unavailable.
|
|
|
|
|
-
|
|
|
|
|
-unless ( $buff ) {
|
|
|
|
|
- print "Failed. No response to helo datagram (master browser query) from ", $broadcast_addr ? $broadcast_addr : "@citrix_servers", ".\n" ;
|
|
|
|
|
- exit $ERRORS{CRITICAL} ;
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-($rport, $raddr) = sockaddr_in( $remote_host );
|
|
|
|
|
-$rhost = gethostbyaddr( $raddr, AF_INET );
|
|
|
|
|
-my @tmpbuf = unpack('C*', $buff );
|
|
|
|
|
-if ( $debug ) {
|
|
|
|
|
- print "$rhost:$rport responded with: ",length($buff), " bytes\n";
|
|
|
|
|
- &dump($buff) ;
|
|
|
|
|
-} #if debug
|
|
|
|
|
-
|
|
|
|
|
-# now we have a response, then we need to figure out the master browser, and
|
|
|
|
|
-# query it for published applications...
|
|
|
|
|
-
|
|
|
|
|
-my $master_browser = join '.', @tmpbuf[32..35] ;
|
|
|
|
|
-
|
|
|
|
|
-# ok should probably error check this, because it's remotely possible
|
|
|
|
|
-# that a server response might be completely wrong...
|
|
|
|
|
-
|
|
|
|
|
-print "Master browser = $master_browser\n" if $debug ;
|
|
|
|
|
-
|
|
|
|
|
-$send_addr = sockaddr_in(ICA_PORT, inet_aton($master_browser));
|
|
|
|
|
-
|
|
|
|
|
-if ( $broadcast_addr ) {
|
|
|
|
|
- print "using broadcast query\n" if $debug ;
|
|
|
|
|
- @query_message = @bcast_query_app;
|
|
|
|
|
-} else {
|
|
|
|
|
- print "using directed query\n" if $debug ;
|
|
|
|
|
- @query_message = @direct_query_app;
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-# now we send the appropriate query string, to the master browser we've found.
|
|
|
|
|
-
|
|
|
|
|
-$buff = '';
|
|
|
|
|
-$this_test = 0 ;
|
|
|
|
|
-
|
|
|
|
|
-print "Querying master browser for published application list\n" if $debug ;
|
|
|
|
|
-
|
|
|
|
|
-while ( ++$this_test <= TEST_COUNT && !$buff ) {
|
|
|
|
|
- print "Sending application query datagram. datagram number: ", $this_test, "\n" if $debug ;
|
|
|
|
|
- &dump(pack('C*', @query_message)) if $debug ;
|
|
|
|
|
- $Udp->send( pack ('C*', @query_message), 0, $send_addr );
|
|
|
|
|
-
|
|
|
|
|
- if ( $select->can_read($Timeout) ) {
|
|
|
|
|
- $remote_host = $Udp->recv($buff, BUFFER_SIZE, 0 );
|
|
|
|
|
- # $buff = substr($buff, 32) ;
|
|
|
|
|
- # Hope that ICA preamble is first 32 bytes
|
|
|
|
|
- }
|
|
|
|
|
-
|
|
|
|
|
- # long application lists are delivered in multiple packets
|
|
|
|
|
-
|
|
|
|
|
- my $buff2 = '' ;
|
|
|
|
|
- while ( $long_list && $select->can_read($Timeout) ) {
|
|
|
|
|
- $remote_host = $Udp->recv($buff2, BUFFER_SIZE, 0 );
|
|
|
|
|
- $buff .= $buff2 if $buff2 ;
|
|
|
|
|
- # $buff .= substr($buff2, 32) if $buff2 ;
|
|
|
|
|
- # Hope that ICA preamble is first 32 bytes
|
|
|
|
|
- }
|
|
|
|
|
-
|
|
|
|
|
- last if $buff ;
|
|
|
|
|
- sleep 1 ;
|
|
|
|
|
-
|
|
|
|
|
-} # while test_count
|
|
|
|
|
-
|
|
|
|
|
-unless ( $buff ) {
|
|
|
|
|
- print "Failed. No response to application query datagram from ", $master_browser, ".\n" ;
|
|
|
|
|
- exit $ERRORS{CRITICAL} ;
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-# we got a response from a couple of retries of the app query
|
|
|
|
|
-
|
|
|
|
|
-($rport, $raddr) = sockaddr_in ( $remote_host );
|
|
|
|
|
-$rhost = gethostbyaddr ( $raddr, AF_INET );
|
|
|
|
|
-if ( $debug ) {
|
|
|
|
|
- print "$rhost:$rport responded to app query with: ",length($buff), " bytes\n";
|
|
|
|
|
- &dump($buff) ;
|
|
|
|
|
-} #debug
|
|
|
|
|
-
|
|
|
|
|
-my $app_list = $buff ;
|
|
|
|
|
- # delete nulls in unicode
|
|
|
|
|
- # but only if there is unicode (usually from
|
|
|
|
|
- # broadcast query)
|
|
|
|
|
-
|
|
|
|
|
-$app_list =~ s/(?:(\w| |-)\x00)/$1/g
|
|
|
|
|
- if $app_list =~ /(?:(?:(?:\w| |-)\x00){3,})/ ;
|
|
|
|
|
- # FIXME an application name is
|
|
|
|
|
- # 3 or more unicoded characters
|
|
|
|
|
-
|
|
|
|
|
- # FIXME locale
|
|
|
|
|
- # extract null terminated strings
|
|
|
|
|
-
|
|
|
|
|
-my (@clean_app_list, $clean_app_list) ;
|
|
|
|
|
-$clean_app_list = join(',', @clean_app_list = $app_list =~ m#([A-Za-z](?:\w| |-|[ÄÖÜäöüß])+?(?=\x00))#g ) ;
|
|
|
|
|
-
|
|
|
|
|
- # patch for German umlauts et al from Herr Mike Gerber.
|
|
|
|
|
-
|
|
|
|
|
-# $clean_app_list = join(',', @clean_app_list = $app_list =~ m#([A-Z](?:\w| |-)+?(?=\x00))#g ) ;
|
|
|
|
|
-
|
|
|
|
|
- # FIXME everyones apps don't start with caps
|
|
|
|
|
-
|
|
|
|
|
-print qq(Received list of applications: "$clean_app_list".\n) if $debug ;
|
|
|
|
|
-
|
|
|
|
|
-if ( scalar @crit_pub_apps and my @missing = &simple_diff(\@clean_app_list, \@crit_pub_apps) ) {
|
|
|
|
|
- print qq(Failed. "@missing" not found in list of published applications),
|
|
|
|
|
- qq( "$clean_app_list" from master browser "$master_browser".\n) ;
|
|
|
|
|
- exit $ERRORS{CRITICAL} ;
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-if ( my @missing = &simple_diff(\@clean_app_list, \@warn_pub_apps) ) {
|
|
|
|
|
- print qq(Warning. "@missing" not found in list of published applications),
|
|
|
|
|
- qq( "$clean_app_list" from master browser "$master_browser".\n) ;
|
|
|
|
|
- exit $ERRORS{WARNING} ;
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-my @x = (@crit_pub_apps, @warn_pub_apps) ;
|
|
|
|
|
-my $blah = ( scalar(@x) == 1 ? 'the published application "' . join(',', @x) . '" is available' :
|
|
|
|
|
- 'the published applications "' . join(',', @x) . '" are available' ) ;
|
|
|
|
|
-
|
|
|
|
|
-print qq(Ok. Citrix master browser "$master_browser" reported that $blah.\n) ;
|
|
|
|
|
-exit $ERRORS{OK} ;
|
|
|
|
|
-
|
|
|
|
|
-# sleep $Timeout;
|
|
|
|
|
- # because otherwise we can get responses from
|
|
|
|
|
- # the WRONG servers. DOH
|
|
|
|
|
-close $Udp;
|
|
|
|
|
-
|
|
|
|
|
-
|
|
|
|
|
-sub print_usage () {
|
|
|
|
|
- print "Usage: $PROGNAME (-B <broadcast_address>| -C <citrix_server>..) -W <pub_app1,pub_app2..> -P <pub_app1,pub_app2,>\n";
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-sub print_help () {
|
|
|
|
|
- print_revision($PROGNAME,'$Revision$ ');
|
|
|
|
|
- print "Copyright (c) 2002 Ed Rolison/Tom De Blende/Karl DeBisschop/S Hopcroft
|
|
|
|
|
-
|
|
|
|
|
-Perl Check Citrix plugin for NetSaint.
|
|
|
|
|
-
|
|
|
|
|
-Returns OK if the Citrix master browser returns a 'published application' list that contain names specified by the -W or -P options
|
|
|
|
|
-
|
|
|
|
|
-The plugin works by
|
|
|
|
|
- If the -B option is specified, sending a broadcast helo to find the address of the Citrix master browser in the specified subnet.
|
|
|
|
|
- return critical if there is no reply;
|
|
|
|
|
- Else if the -C option is specified
|
|
|
|
|
- send a direct helo to the specified server until there is a response (containing the address of the Citrix master browser)
|
|
|
|
|
-
|
|
|
|
|
- Query the master browser (using a 'broadcast published applications query ' if -B) and compare the published applications returned
|
|
|
|
|
- to those specified by -W and -P options
|
|
|
|
|
-
|
|
|
|
|
- return Critical if the published applications specified by -P is not a subset of the query responses;
|
|
|
|
|
- return Warning if the published applications specified by -W is not a subset of the query responses;
|
|
|
|
|
- return OK
|
|
|
|
|
-
|
|
|
|
|
-";
|
|
|
|
|
- print_usage();
|
|
|
|
|
- print '
|
|
|
|
|
--B, --broadcast_address=STRING
|
|
|
|
|
- The broadcast address that should contain Citrix master browser. This option takes precedence over -C.
|
|
|
|
|
--C, --citrix_server:STRING
|
|
|
|
|
- Optional __name(s)__ of Citrix servers that could be the master browser (used when broadcast not possible).
|
|
|
|
|
--L, --long_list
|
|
|
|
|
- Set this if you have heaps of published applications (ie more than will fit in _one_ UDP packet)
|
|
|
|
|
--P, --crit_published_app=STRING
|
|
|
|
|
- Optional comma separated list of published application that must be in the response from the master browser.
|
|
|
|
|
- Check returns critical otherwise.
|
|
|
|
|
--T, --packet-timeout:INTEGER
|
|
|
|
|
- Time to wait for UDP packets (default 1 sec).
|
|
|
|
|
--W, --warn_published_app=STRING
|
|
|
|
|
- Optional comma separated list of published application that should be in the response from the master browser.
|
|
|
|
|
- Check returns warning otherwise.
|
|
|
|
|
--d, --debug
|
|
|
|
|
- Debugging output.
|
|
|
|
|
--h, --help
|
|
|
|
|
- This stuff.
|
|
|
|
|
-
|
|
|
|
|
-';
|
|
|
|
|
- support();
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-sub version () {
|
|
|
|
|
- print_revision($PROGNAME,'$Revision$ ');
|
|
|
|
|
- exit $ERRORS{'OK'};
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-sub help () {
|
|
|
|
|
- print_help();
|
|
|
|
|
- exit $ERRORS{'OK'};
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-sub dump {
|
|
|
|
|
- my ($x) = shift @_ ;
|
|
|
|
|
- my (@x, @y, $y, $i, $rowcount) ;
|
|
|
|
|
- my ($nr, $j, $number_in_row, $number_of_bytes) ;
|
|
|
|
|
- my $dump ;
|
|
|
|
|
-
|
|
|
|
|
- $number_in_row = 16 ;
|
|
|
|
|
- $number_of_bytes = length $x ;
|
|
|
|
|
- $nr = 0 ;
|
|
|
|
|
-
|
|
|
|
|
- # styled on tethereal.
|
|
|
|
|
-
|
|
|
|
|
- foreach $j (1 .. int( $number_of_bytes / $number_in_row) ) {
|
|
|
|
|
- $y = substr($x, ($j - 1)*$number_in_row, $number_in_row) ;
|
|
|
|
|
- @y = unpack("C*", $y) ;
|
|
|
|
|
- $y =~ tr /\x00-\x19/./ ;
|
|
|
|
|
- $rowcount = sprintf("%4.4x", ($j - 1) * 0x10 ) ;
|
|
|
|
|
- $dump .= sprintf "%s %s %s\n", $rowcount, join(" ", map { sprintf "%2.2x", $_} @y), $y ;
|
|
|
|
|
- $nr++ ;
|
|
|
|
|
- }
|
|
|
|
|
-
|
|
|
|
|
- if ( $number_of_bytes % $number_in_row > 0 ) {
|
|
|
|
|
- my $spaces_to_text = $number_in_row * 3 - 1 + 3 ;
|
|
|
|
|
- $rowcount = sprintf("%4.4x", $nr * 0x10 ) ;
|
|
|
|
|
- $y = substr($x, $nr * $number_in_row ) ;
|
|
|
|
|
- @y = unpack("C*", $y) ;
|
|
|
|
|
- my $bytes = join(" ", map { sprintf "%2.2x", $_} @y) ;
|
|
|
|
|
- my $spaces = ' ' x ($spaces_to_text - length($bytes)) ;
|
|
|
|
|
- $dump .= sprintf "%s %s%s%s\n", $rowcount, $bytes, $spaces, $y ;
|
|
|
|
|
- }
|
|
|
|
|
-
|
|
|
|
|
- print $dump, "\n" ;
|
|
|
|
|
-
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-sub tethereal2list {
|
|
|
|
|
- my ($tethereal_dump, $start_byte) = @_ ;
|
|
|
|
|
-
|
|
|
|
|
- # return an array containing qw(0xef 0xab 0x00 ...) from a tethereal trace.
|
|
|
|
|
- # skip all stuff until the first byte given by $start_byte.
|
|
|
|
|
-
|
|
|
|
|
- return undef unless $tethereal_dump =~ /\d\d\d\d \S\S(?: \S\S){1,15}/ ;
|
|
|
|
|
-
|
|
|
|
|
- my $hex_start_byte = hex($start_byte) ;
|
|
|
|
|
- my @x = $tethereal_dump =~ m#(.+)#g ;
|
|
|
|
|
- my @y = map unpack("x6 a47", $_), @x ;
|
|
|
|
|
- my @z = map { my $y = $_; $y =~ s/(\S\S)/hex($1)/eg; my @a = split(' ', $y); @a } @y ;
|
|
|
|
|
- shift @z, while $z[0] ne $hex_start_byte ;
|
|
|
|
|
-
|
|
|
|
|
- @z ;
|
|
|
|
|
-
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-sub simple_diff {
|
|
|
|
|
-
|
|
|
|
|
- my ( $a_list, $b_list) = @_ ;
|
|
|
|
|
-
|
|
|
|
|
- # simple set difference 'Recipe 4.7 Perl Cookbook', Christiansen and Torkington
|
|
|
|
|
-
|
|
|
|
|
- my (%seen, @missing) ;
|
|
|
|
|
-
|
|
|
|
|
- @seen{@$a_list} = () ;
|
|
|
|
|
-
|
|
|
|
|
- foreach my $item (@$b_list) {
|
|
|
|
|
- push @missing, $item unless exists $seen{$item} ;
|
|
|
|
|
- }
|
|
|
|
|
-
|
|
|
|
|
- @missing ;
|
|
|
|
|
-}
|
|
|
|
|
-
|
|
|
|
|
-
|
|
|
|
|
-
|
|
|