1package Net::Analysis::Listener::Base; 2# $Id: Base.pm 131 2005-10-02 17:24:31Z abworrall $ 3 4use 5.008000; 5our $VERSION = '0.01'; 6use strict; 7use warnings; 8use overload q("") => sub { $_[0]->as_string() }; # OO style stringify 9 10use Carp qw(carp croak); 11 12use Params::Validate qw(:all); 13 14# {{{ POD 15 16=head1 NAME 17 18Net::Analysis::Listener::Base - base class for event listeners 19 20=head1 SYNOPSIS 21 22This module should be subclassed as follows: 23 24 package Net::Analysis::Listener::MyThing; 25 26 use base 'Net::Analysis::Listener::Base'; 27 28 sub event_listener { 29 my ($self, $args_hash) = @_; 30 ... do something ... 31 32 if (event_is_exciting($args_hash)) { 33 $self->emit (name => 'my_event', 34 args => {what => 'listeners to this event will get'}); 35 } 36 } 37 38=head1 DESCRIPTION 39 40This module is a virtual base class for Listeners. To create a new listener, 41just subclass this, and add methods. If you want to listen to an event, create 42a method with the name of that event - the dispatcher takes care of the rest. 43 44If you want to store state between events (such as a hash of open sessions), 45stuff it into C<$self>. Any configuration for your listener will also be 46exploded all over $<$self>, so take care. Subclasses can use anything in $self 47they want, except the key '_', which contains private stuff used by the base 48class. 49 50You can emit events if you like; if you add new types of event, take care not 51to collide with existing ones (e.g. tcp_blah, http_blah). The best way to do 52this is to select a prefix for your event names based on your protocol. 53 54=head1 INHERITED METHODS 55 56B<You should just inherit these methods>, you don't need to implement them. 57They're documented here for reference, so don't be put off - they can be safely 58ignored :) 59 60=cut 61 62# }}} 63 64# These should not be overridden 65# XXXX Create a DESTROY method that breaks all the circular refs. 66# {{{ new 67 68# {{{ POD 69 70=head2 new (dispatcher => $obj [, config => $hash] [, pos => 'first|last']) 71 72Mandatory argument is the dispatcher object which will dispatch any events 73that originate from this module, or any that subclass from it. 74 75Note that we immediately register this new object with the dispatcher; this 76will create circular references. 77 78The config hash is optional. Standard key/val pairs are: 79 80 * v => 0..3 (verbosity; 0==silent, 9==noisy) 81 82The pos parameter is optional. It specifies if the listener sould catch events 83first, or last. Only one listener can be first, or last. 84 85The rest of the hash varies on a per-listener basis. 86 87The returned object has one reserved field: C<$self->{_}>. This is used for the 88behind-the-scenes plumbing. All other fields in C<$self> are free for the 89subclass to use. 90 91Note that the config hash is exploded over C<$self>; that is, C<$self->{v}> 92will contain the verbosity value passed in via the config hash (or a 93default, if no config is passed in.) 94 95=cut 96 97# }}} 98 99sub new { 100 my ($class) = shift; 101 102 my %args = validate (@_, { 103 dispatcher => { can => 'emit_event' }, 104 pos => { regex => qr/^(first|last)$/, 105 optional => 1}, 106 config => { type => HASHREF, 107 default => {v => 0}, }, 108 } 109 ); 110 111 # Place the dispatcher into our private subhash 112 my %h = ('_' => {dispatcher => $args{dispatcher}}); 113 114 my ($self) = bless (\%h, $class); 115 116 # Allow the module to validate the configuration, if it wants 117 my $cnf = $self->validate_configuration (%{$args{config}}); 118 if (! defined $cnf) { 119 carp "no configuration, despite default setting above ?"; 120 return undef; 121 } 122 123 # Explode the config all over self, provided we haven't already used it 124 foreach my $k (keys %{$cnf}) { 125 croak "bad config '$k': '$k' is reserved !\n" if (exists $h{$k}); 126 $h{$k} = $cnf->{$k}; 127 } 128 129 # If a position was specified, put it where the dispatcher will look for it 130 $self->{pos} = $args{pos} if (exists $args{pos}); 131 132 $h{_}{dispatcher}->add_listener (listener => $self); # Circular ref joy 133 134 return $self; 135} 136 137# }}} 138# {{{ emit 139 140=head2 emit (...) 141 142This is a convenience wrapper on top of 143L<Net::Analysis::Dispatcher::emit_event>. It takes exactly the same arguments. 144Please refer to that module for documentation. 145 146=cut 147 148sub emit { 149 my ($self) = shift; 150 $self->{_}{dispatcher}->emit_event (@_); 151} 152 153# }}} 154# {{{ trace 155 156sub trace { 157 my ($self) = shift; 158 159 foreach (@_) { 160 my $l = $_; # Skip 'Modification of a read-only value' errors 161 chomp ($l); 162 print "$l\n"; 163 } 164} 165 166# }}} 167 168# These can (should) be overridden 169# {{{ as_string 170 171# This should really be overridden by our subclass 172 173sub as_string { 174 my ($self) = @_; 175 my $s = ''; 176 177 $s .= "[".ref($self)."]"; 178 179 return $s; 180} 181 182# }}} 183sub validate_configuration { my $self=shift; return {@_}; } 184 185#sub setup {} 186#sub teardown {} 187 188 189# Utilities for viewing binary data 190# {{{ sanitize_raw 191 192sub sanitize_raw { 193 my ($self, $raw, $max, $append_binary) = @_; 194 $raw = substr($raw,0,$max) if ($max && length($raw) > $max); 195 196 my $s = $raw; 197 $s =~ s {([^\x20-\x7e])} {.}g; 198 $s .= " ".$self->map2bin($raw) if ($append_binary); 199 return "{$s}"; 200} 201 202# }}} 203# {{{ map2bin 204 205sub map2bin { 206 my ($self,$raw) = @_; 207 my $bin = unpack("B*", $raw); 208 $bin =~ s{([^ ]{8})(?! )}{ $1}g; 209 $bin =~ s{(^ *| *$)}{}g; 210 return "<$bin>"; 211} 212 213# }}} 214# {{{ map2hex 215 216sub map2hex { 217 my ($self,$raw, $prefix, $append_binary) = @_; 218 219 $prefix ||= ''; 220 my $hex = unpack("H*", $raw); 221 222 $hex =~ s {([0-9a-f]{2}(?! ))} { $1}mg; 223 224 $hex =~ s {(( [0-9a-f]{2}){16})} 225 {"$1 ".$self->hex2saferaw($1,$append_binary)."\n"}emg; 226 227 # Unfinished last line 228 $hex =~ s {(( [0-9a-f]{2})*)$} 229 {sprintf("%-47.47s ",$1) .$self->hex2saferaw($1,$append_binary)."\n"}es; 230 231 chomp($hex); 232 233 $hex =~ s/^/$prefix/msg; 234 235 return $hex."\n"; 236} 237 238sub hex2saferaw { 239 my ($self, $hex, $append_binary) = @_; 240 241 $hex =~ s {\s+} {}mg; 242 my $raw = pack("H*", $hex); 243 244 return $self->sanitize_raw($raw,undef,$append_binary); 245} 246 247# }}} 248 2491; 250__END__ 251# {{{ POD 252 253=head2 EXPORT 254 255None by default. 256 257=head1 SEE ALSO 258 259Net::Analysis::Dispatcher 260 261Net::Analysis::Listener::HTTP - a useful example listener 262 263=head1 AUTHOR 264 265Adam B. Worrall, E<lt>worrall@cpan.orgE<gt> 266 267=head1 COPYRIGHT AND LICENSE 268 269Copyright (C) 2004 by Adam B. Worrall 270 271This library is free software; you can redistribute it and/or modify 272it under the same terms as Perl itself, either Perl version 5.8.5 or, 273at your option, any later version of Perl 5 you may have available. 274 275=cut 276 277# }}} 278 279# {{{ -------------------------={ E N D }=---------------------------------- 280 281# Local variables: 282# folded-file: t 283# end: 284 285# }}} 286