sendpage  1.001001
About: Sendpage sends alphanumeric pages to a pager. Development version.
  Fossies Dox: sendpage-1.001001.tar.gz  ("inofficial" and yet experimental doxygen-generated source code documentation)  

Modem.pm
Go to the documentation of this file.
1 package Sendpage::Modem;
2 
3 # Modem.pm extends the Device::SerialPort package, and adds a few things
4 #
5 # $Id: Modem.pm 224 2006-08-27 17:55:05Z keescook $
6 #
7 # Copyright (C) 2000-2004 Kees Cook
8 # kees@outflux.net, http://outflux.net/
9 #
10 # This program is free software; you can redistribute it and/or
11 # modify it under the terms of the GNU General Public License
12 # as published by the Free Software Foundation; either version 2
13 # of the License, or (at your option) any later version.
14 #
15 # This program is distributed in the hope that it will be useful,
16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 # GNU General Public License for more details.
19 #
20 # You should have received a copy of the GNU General Public License
21 # along with this program; if not, write to the Free Software
22 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
23 # <URL:http://www.gnu.org/copyleft/gpl.html>
24 
25 use strict;
26 use warnings;
27 
28 use POSIX;
29 use IO::Handle;
30 use Sendpage::KeesLog;
31 
32 # FIXME: Hey! Duh! I should use the OS auto-discovery system to get the
33 # right serial device module here!
34 use Device::SerialPort;
35 our @ISA = ("Device::SerialPort");
36 
37 =head1 NAME
38 
39 Sendpage::Modem - extends the Device::SerialPort package
40 
41 =head1 SYNOPSIS
42 
43  $modem = Sendpage::Modem->new($params);
44  $modem->init($baud, $parity, $data, $stop, $flow, $str);
45  $modem->ready($functionname);
46  $modem->dial($areacode, $phonenumber, $timeout);
47  $modem->chat($send, $resend, $expect, $timeout,
48  $retries, $dealbreaker, $carrier);
49  $modem->hangup();
50 
51  $str = Sendpage::Modem->HexStr("tab:\t cr:\r");
52 
53 =head1 DESCRIPTION
54 
55 This module is used by L<sendpage> as an interface for working with
56 modem devices by extending the L<Device::SerialPort> module.
57 
58 =head1 BUGS
59 
60 This needs more docs.
61 
62 =cut
63 
64 
65 # globals
66 my $SPEED = 10; # arbitrary: how much to speed up the char reader timeout
67 
68 # new methods here are:
69 # init - inits modem
70 # dial - dials number (returns like "write")
71 # hangup - hangs up modem
72 
73 =pod
74 
75 The currently-implemented methods are:
76 
77 =over 4
78 
79 =item new LIST
80 
81 Instantiates a new Modem.
82 
83 Accepts modem parameters.
84 
85 =cut
86 
87 # new modem
88 # takes:
89 # modem parameters
90 #
91 sub new
92 {
93  # local vars
94  my ($lockfile, $realdev, $pid);
95 
96  # get our args
97  my $proto = shift;
98  my %arg = @_;
99 
100  my $name = $arg{Name};
101 
102  my $dev = $arg{Dev};
103  my $lockprefix = $arg{Lockprefix};
104  my $debug = $arg{Debug};
105  my $log = $arg{Log} || new Sendpage::KeesLog(Syslog => 0);
106 
107  # sanity check our config options
108  unless (defined $lockprefix) {
109  $log->do('alert',"Modem '$name' has no lockprefix defined");
110  undef $log;
111  return undef;
112  }
113  unless (defined($dev) || $dev ne "/dev/null") {
114  $log->do('alert',"Modem '$name' has no device defined");
115  undef $log;
116  return undef;
117  }
118 
119  # We need to build the name of the lock file
120  $lockfile = $lockprefix;
121 
122  # FIXME: I need clarification on this: should we discover the
123  # true name of the device or not?
124  ## figure out what the REAL device name is
125  #if (!defined($realdev=readlink($dev))) {
126  # # not a symlink
127  $realdev = $dev;
128  #}
129 
130  # now, chop the name of the dev off
131  my @parts = split m#/#, $realdev;
132  $lockfile .= pop @parts;
133  # $lockfile should now be in the form "/var/lock/LCK..ttyS0"
134 
135  $log->do('debug', "Locking with '$lockfile' ...") if $debug;
136 
137  # FIXME: I still don't feel that this is a Perlish thing to do,
138  # but it works; I'll have to dig more in PerlMonks, or in the
139  # Cookbook...
140  #
141  # Kees told me that the following implements a UUCP-style locking
142  # mechanism, but I suppose I could add Perl's flock() here for added
143  # strength.
144  until (sysopen(LOCKFILE, "$lockfile", O_EXCL | O_CREAT | O_RDWR)) {
145  if ($! == EEXIST) {
146  # Our lockfile previously existed
147  if (sysopen(LOCKFILE, "$lockfile", O_RDONLY)) {
148  # read PID
149  local $_ = <LOCKFILE> || "";
150  close LOCKFILE;
151  $pid = (/^\s*(\d+)/) ? $1 : -1;
152  undef $!; # whoa: we need to clear this
153  if ($pid > 0) {
154  # Someone used the device recently
155  kill 0, $pid; # check if $pid is alive
156  if ($! == ESRCH) {
157  # $pid is deceased (or zombiefied)
158  $log->do('debug',
159  "Modem '$name': stale lockfile from PID $pid removed");
160  unlink($lockfile), next;
161  }
162  } elsif ($pid < 0) {
163  # We shouldn't really go here, unless something
164  # nasty is up...
165  $log->do('warning',
166  "Modem '$name': malformated lockfile being removed");
167  unlink($lockfile), next;
168  }
169  # allow PID '0' from the "lockfile"
170  # program to exist indefinitely.
171  }
172 
173  # cannot touch lockfile
174  $log->do('warning',
175  "Modem '$name': '$dev' is locked by process '$pid'");
176  undef $log;
177  return undef;
178  } else {
179  $log->do('alert',
180  "Modem '$name': cannot access lockfile '$lockfile': %s",$!);
181  undef $log;
182  return undef;
183  }
184  }
185 
186  # we have the lock file now
187  print LOCKFILE sprintf("%10d\n", $$);
188  close LOCKFILE;
189 
190  # handle inheritance?
191  my $class = ref($proto) || $proto;
192  my $self = $class->SUPER::new($dev); # this should be SerialPort
193  my $ref; # Hmmm, unused?
194 
195  unless (defined $self) {
196  $log->do('crit',
197  "Modem '$name': could not start Device::Serial port: %s",
198  $!);
199  unlink $lockfile;
200  undef $log;
201  return undef;
202  }
203 
204  # save our stateful information
205  $self->{MYNAME} = $name; # name of the modem
206  $self->{LOCKFILE} = $lockfile; # where our lockfile is
207  $self->{DEBUG} = $debug; # debug mode?
208  $self->{INITDONE} = 0; # we have not run "init"
209 
210  # internal buffer for 'chat'
211  $self->{BUFFER} = "";
212 
213  bless $self, $class;
214 
215  # Do Device::SerialPort capability sanity checking
216  unless ($self->can_ioctl()) {
217  $log->do('crit',
218  "Modem '$name' cannot do ioctl's. Did 'configure' run correctly when you built sendpage?");
219  # get rid of modem
220  $self->unlock();
221  undef $log;
222  undef $self;
223  }
224 
225  # grab config settings
226  foreach my $index ( qw(Baud Parity StrictParity Data Stop Flow Init InitOK
227  InitWait InitRetry Error Dial DialOK DialWait
228  DialRetry NoCarrier CarrierDetect DTRToggleTime
229  AreaCode LongDist DialOut) ) {
230  if (defined($arg{$index})) {
231  $self->{$index} = $arg{$index};
232  $log->do('debug',
233  "Modem '$name' setting '$index': '". $self->{$index} . "'")
234  if $self->{DEBUG};
235  }
236  }
237 
238  $self->{LOG} = $log; # get the log object
239  return $self;
240 }
241 
242 =item init EXPR
243 
244 Initialize a Sendpage::Device with given settings and sends the init
245 string.
246 
247 Accepts hash consisting of baud rate, parity, data bits, stop bits, flow
248 control flag, init string, and parity strictness (for Win32 systems.)
249 
250 Emits whatever the result of a C<chat> call (inherited from
251 L<Device::SerialPort>,) C<undef> otherwise.
252 
253 =cut
254 
255 # init settings and send init string
256 # takes:
257 # baud, parity, data, stop, flow, init str
258 sub init
259 {
260  my $self = shift;
261  my %arg = @_;
262  my $name = "Modem '$self->{MYNAME}'";
263 
264  # check if modem is locked
265  unless (defined $self->{LOCKFILE}) {
266  $self->{LOG}->do('crit',"init: $name not locked");
267  return undef;
268  }
269 
270  my %settings =
271  (
272  Baud => "baud rate",
273  Parity => "parity",
274  Data => "data bits",
275  Stop => "stop bits",
276  Flow => "flow control",
277  Init => "init string",
278  StrictParity => "strict parity",
279  );
280 
281  foreach my $setting (keys %settings) {
282  $arg{$setting} ||= $self->{$setting};
283 
284  # sanity check our config options
285  unless (defined $arg{$setting}) {
286  $self->{LOG}->do('alert',
287  "$name has no $settings{$setting} defined!");
288  return undef;
289  }
290  }
291 
292  # if (!defined($str)) {
293  # $self->{LOG}->do('alert', "$name has no init string defined!");
294  # return undef;
295  # }
296 
297  # pass various settings through to the serial port
298  $self->alias($self->{MYNAME});
299 
300  # methods hash
301  my %method_set =
302  (
303  Baud => $self->baudrate($arg{Baud}),
304  Parity => $self->parity($arg{Parity}),
305  Data => $self->databits($arg{Data}),
306  Stop => $self->stopbits($arg{Stop}),
307  Flow => $self->handshake($arg{Flow}),
308  );
309 
310  foreach my $setting (keys %method_set) {
311  my $set = $method_set{$setting};
312  $self->{LOG}->do('debug',
313  "$setting requested: '$arg{$setting} $setting set: '$set'")
314  if $self->{DEBUG};
315  if ($arg{$setting} ne $set) {
316  $self->{LOG}->do('alert', "$name failed to set $settings{$setting}!");
317  return undef;
318  }
319  }
320 
321  # Make sure we're backward compatible with Win32
322  if ($self->can("stty_inpck") && $self->can("stty_istrip")) {
323  if ($arg{StrictParity}) {
324  $self->stty_inpck(1);
325  $self->stty_istrip(1);
326  } else {
327  $self->stty_inpck(0);
328  $self->stty_istrip(0);
329  }
330  }
331 
332  # set a char timeout for modem commands
333  $self->read_char_time(0); # avg time between read char
334  $self->read_const_time(1000/$SPEED); # delay between calls
335 
336  if ($self->{DTRToggleTime} != 0) {
337  # hang up just in case
338  $self->{LOG}->do('debug', "reseting DTR ...")
339  if $self->{DEBUG};
340  # force the dtr down
341  $self->dtr_active(0);
342  select(undef, undef, undef, $self->{DTRToggleTime});
343  $self->dtr_active(1);
344  } else {
345  $self->{LOG}->do('debug', "skipping DTR toggle ...")
346  if $self->{DEBUG};
347  }
348 
349  # make sure the RTS is up
350  $self->{LOG}->do('debug', "forcing RTS ...") if $self->{DEBUG};
351  $self->rts_active('T');
352 
353  my $result = undef;
354  # allow for blank inits (direct attaches)
355  if ($arg{Init} eq "") {
356  $self->{LOG}->do('debug', "skipping init string ...")
357  if $self->{DEBUG};
358  $result = 1;
359  } else {
360  # send the init string through
361  $self->{INITDONE} = 1; # frame this to let chat work
362  $result = $self->chat("$arg{Init}\r", "$arg{Init}\r",
363  $self->{InitOK},
364  $self->{InitWait},
365  $self->{InitRetry},
366  $self->{Error},
367  "off",
368  );
369  $self->{INITDONE} = 0; # disable again
370  }
371  if (defined $result) {
372  $self->{INITDONE} = 1;
373  }
374  return $result;
375 }
376 
377 =item ready FUNCNAME
378 
379 Checks is a Sendpage::Device is locked and initialized properly.
380 
381 Accepts the name of a function to be used after C<check>ing.
382 
383 Emits 1 if ok, C<undef> otherwise.
384 
385 =cut
386 
387 sub ready
388 {
389  my $self = shift;
390  my $func = shift;
391 
392  unless (defined $self->{LOCKFILE}) {
393  $self->{LOG}->do('crit', "$func: Modem '$self->{MYNAME}' not locked");
394  return undef;
395  }
396  unless ($self->{INITDONE}) {
397  $self->{LOG}->do('crit',
398  "$func: Modem '$self->{MYNAME}' not initialized");
399  return undef;
400  }
401  return 1;
402 }
403 
404 =item dial LIST
405 
406 Dial a number.
407 
408 Accepts the I<area code> number, the I<number> to be dialed, I<waiting
409 time> (in seconds) between dials, and the number of I<dial retries>
410 before giving up.
411 
412 Emits C<undef> if unsuccessful, or the result of the succeeding C<chat>
413 call.
414 
415 =cut
416 
417 # FIXME: implement dial retries
418 sub dial
419 {
420  my $self = shift;
421  my %arg = @_;
422 # my ($self, $dial_areacode, $dial_num, $dialwait, $dialretries) = @_;
423 
424  return undef unless $self->ready("dial");
425 
426  my $modem_dial = $self->{Dial};
427  my $modem_areacode = $self->{AreaCode};
428  my $modem_longdist = $self->{LongDist};
429  my $modem_dialout = $self->{DialOut};
430 
431  $arg{DialWait} ||= $self->{DialWait};
432  $arg{DialRetry} ||= $self->{DialRetry};
433 
434  # allow for blank dial strs (direct attaches)
435  if ($modem_dial eq "") {
436  $self->{LOG}->do('debug', "skipping dial ...")
437  if $self->{DEBUG};
438  return 1;
439  }
440 
441  unless (defined($arg{PhoneNum}) || $arg{PhoneNum} ne "") {
442  $self->{LOG}->do('err', "Nothing to dial (no phone number)");
443  return undef;
444  }
445 
446  my $actual_num = "";
447  my $report = "";
448 
449  if (defined($arg{AreaCode}) && defined($modem_areacode)) {
450  if ($arg{AreaCode} != $modem_areacode) {
451  $actual_num = $modem_longdist . $arg{AreaCode};
452  $report = "LongDist: '$modem_longdist' ";
453  $report .= "PCAreaCode: '$arg{AreaCode}' ";
454  } else {
455  $report = "(Not LongDist) ";
456  }
457  } else {
458  # add the area code anyway
459  $actual_num = $arg{AreaCode};
460  if (defined $arg{AreaCode}) {
461  $report = "(No Modem AreaCode) ";
462  $report .= "PCAreaCode: '$arg{AreaCode}' "
463  }
464  }
465  # we always need to end the dialing with the phone number...
466  $actual_num .= $arg{PhoneNum};
467  $report .= "Num: '$arg{PhoneNum}'";
468 
469  if ($modem_dialout ne "") {
470  $report = "DialOut: '$modem_dialout' " . $report;
471  }
472 
473  $self->{LOG}->do('debug', "Calling with %s", $report) if $self->{DEBUG};
474 
475  return $self->chat($modem_dial . $modem_dialout . $actual_num . "\r",
476  "", $self->{DialOK}, $arg{DialWait}, 1,
477  $self->{NoCarrier}, "off",
478  );
479 }
480 
481 =item safe_write STRING
482 
483 Write a message text.
484 
485 Accepts a message string.
486 
487 Emits 1 if successful, C<undef> otherwise.
488 
489 =cut
490 
491 sub safe_write
492 {
493  my ($self, $text) = @_;
494  my ($textlen, $written);
495 
496  unless (defined $self->{LOCKFILE}) {
497  $self->{LOG}->do('crit',
498  "safe_write: Modem '$self->{MYNAME}' not locked");
499  return undef;
500  }
501 
502 
503  $textlen = length($text);
504  do {
505  $written = $self->write($text);
506  if (!defined($written)) {
507  $self->{LOG}->do('crit', "write totally failed");
508  return undef;
509  } elsif ($written != $textlen) {
510  $self->{LOG}->do('warning',"write was incomplete!?! retrying...");
511  $text = substr($text, $written);
512  }
513  if ($self->{DEBUG}) {
514  $self->{LOG}->do('debug',"wrote: %d %s",
515  $written,
516  $self->HexStr(substr($text, 0, $written)));
517  }
518  $textlen -= $written;
519  } while ($textlen > 0);
520  return 1;
521 }
522 
523 =item chat LIST
524 
525 Examine a stream and interact like C<expect> to find and respond to
526 strings using regular expressions.
527 
528 Accepts FIXME
529 
530 Emits FIXME
531 
532 =cut
533 
534 # FIXME: more docs here
535 # This function examines a stream and interacts like "expect" to find and
536 # respond to strings, using regular expressions.
537 # Args:
538 # send: what to immediately send now
539 # kicker: what to send after a timeout waiting for the expected text
540 # expect: what to look for (perl regexp)
541 # timeout:time in seconds to wait for the "expect"ed text
542 # retries:how many times to send the kicker and restart the timeout
543 # dealbreaker:a regexp that indicates total failure (NO CARRIER, etc)
544 # carrier:should the carrier detect signal on the modem
545 # be ignored during this chat, or use DSR? ("on","off", "dsr")
546 sub chat {
547  my $self = shift;
548  my ($send, $kicker, $expect, $timeout, $retries, $dealbreaker, $carrier) = @_;
549  my ($got);
550 
551  return undef unless $self->ready("chat");
552 
553  $carrier = $self->{CarrierDetect} unless defined $carrier;
554  $got = $self->{BUFFER};
555 
556  if ($self->{DEBUG}) {
557  $self->{LOG}->do('debug', "\tto send: %s", $self->HexStr($send));
558  $self->{LOG}->do('debug', "\twant: %s", $self->HexStr($expect));
559  $self->{LOG}->do('debug', "\tkicker: %s", $self->HexStr($kicker));
560  $self->{LOG}->do('debug', "\ttimeout: $timeout retries: $retries");
561  $self->{LOG}->do('debug', "\thave: %s", $self->HexStr($got));
562  }
563 
564  # useful variables:
565  # $got contains the full text of chars read
566 
567 
568  #LOOP:
569  # send initial text
570  # start retry loop
571  # start timeout loop while reading chars
572  # try to read char
573  # check for sucess
574  # end loop
575  # send kicker
576  # end loop
577 
578 
579  # send initial text no matter what
580  $self->{LOG}->do('alert', "safe_write failed!")
581  if ($send ne "" && !defined($self->safe_write($send)));
582 
583  if ($expect eq "") {
584  $self->{LOG}->do('debug',
585  "chat defaulted to success: no 'expect' regexp");
586  return "";
587  }
588 
589  # initial check for sucess
590  # FIXME: Hmm, using $` and $' is expensive...
591  if ($got =~ /($expect)/) {
592  my $matched = $1;
593  my $upto = $` . $1;
594  $self->{BUFFER} = $'; # keep right of match
595  $self->{LOG}->do('debug', "chat success: %s", $self->HexStr($matched))
596  if $self->{DEBUG};
597  return $upto;
598  }
599  if (defined($dealbreaker) && $got =~ /($dealbreaker)/) {
600  my $matched = $1;
601  my $upto = $` . $1;
602  $self->{BUFFER} = $'; # keep right of match
603  $self->{LOG}->do('debug', "chat failure: %s", $self->HexStr($matched))
604  if $self->{DEBUG};
605  return undef;
606  }
607 
608  # up our timeout to tenths
609  $timeout *= $SPEED;
610 
611  # start retry loop
612  my $tries;
613  for ($tries = 0; $tries < $retries; $tries++) {
614 
615  # send kicker (unless this is the first time through)
616  if ($kicker ne "" && $tries > 0) {
617  $self->{LOG}->do('debug', "timed out, sending kicker")
618  if $self->{DEBUG};
619  $self->{LOG}->do('alert', "safe_write failed!")
620  unless defined $self->safe_write($kicker);
621  }
622 
623  # start timeout loop while reading chars
624  my $timeleft;
625  for ($timeleft = 0; $timeleft < $timeout; $timeleft++) {
626 
627  # do carrier check
628  my $has_carrier = $self->carrier($carrier);
629  if (!$has_carrier) {
630  $self->{LOG}->do('warning',
631  "lost carrier during chat");
632  # modem no longer valid
633  $self->{INITDONE} = 0;
634  return undef;
635  }
636 
637  # try to read char
638  my ($cnt, $avail) = $self->read(255);
639  if ($cnt > 0) {
640  $self->{LOG}->do('debug', "$cnt seen: %s",
641  $self->HexStr($avail))
642  if $self->{DEBUG};
643  $got .= $avail;
644  $self->{LOG}->do('debug', "have: %s", $self->HexStr($got))
645  if $self->{DEBUG};
646  } elsif ($self->{DEBUG}) {
647  my $msg = sprintf("(timeout: %d/%d, retries: %d/%d)",
648  $timeleft / $SPEED, $timeout / $SPEED,
649  $tries, $retries);
650  $self->{LOG}->do('debug', "%s", $msg)
651  if (($timeleft % $SPEED) == 0);
652  }
653 
654  # check for sucess
655  if ($got =~ /($expect)/) {
656  my $matched = $1;
657  my $upto = $` . $1;
658  $self->{BUFFER} = $'; # keep right of match
659  $self->{LOG}->do('debug',
660  "chat success: %s", $self->HexStr($matched))
661  if $self->{DEBUG};
662  return $upto;
663  }
664  if (defined($dealbreaker) && $got =~ /($dealbreaker)/) {
665  my $matched = $1;
666  my $upto = $` . $1;
667  $self->{BUFFER} = $'; # keep right of match
668  $self->{LOG}->do('debug',
669  "chat failure: %s", $self->HexStr($matched))
670  if $self->{DEBUG};
671  return undef;
672  }
673  }
674  }
675 
676  # failure
677  $self->{LOG}->do('debug', "chat failed") if $self->{DEBUG};
678  return undef;
679 }
680 
681 =item carrier STRING
682 
683 Check for the state of the carrier bit.
684 
685 Accepts a I<string> specifying the type of carrier bit check. If C<on>
686 is given, checks for MS_RLSD_ON; if C<dsr>, checks for MS_DSR_ON. If
687 C<off> no checking is done; the number 1 is emitted.
688 
689 FIXME: Better docs here
690 
691 =cut
692 
693 # what is the state of the carrier bit?
694 sub carrier
695 {
696  my $self = shift;
697  my $way = shift; # "on", "off", or "dsr"
698 
699  unless (defined $self->{LOCKFILE}) {
700  $self->{LOG}->do('crit',
701  "carrier: Modem '$self->{MYNAME}' not locked");
702  return undef;
703  }
704 
705  return 1 if ($way =~ /off/i);
706 
707  if ($way =~ /on/i) {
708  my $ModemStatus = $self->modemlines;
709  return (($ModemStatus & $self->MS_RLSD_ON) == $self->MS_RLSD_ON);
710  }
711  if ($way =~ /dsr/i) {
712  my $ModemStatus = $self->modemlines;
713  return (($ModemStatus & $self->MS_DSR_ON) == $self->MS_DSR_ON);
714  }
715  $self->{LOG}->do('crit',
716  "carrier: Modem '$self->{MYNAME}' unknown carrier check '$way'");
717  return undef;
718 }
719 
720 =item hangup
721 
722 Drops the carrier connected to the Sendpage::Device.
723 
724 Emits 1 if successful, C<undef> otherwise.
725 
726 =cut
727 
728 # drop the carrier if it's there
729 sub hangup
730 {
731  my $self = shift;
732 
733  unless (defined $self->{LOCKFILE}) {
734  $self->{LOG}->do('crit', "hangup: Modem '$self->{MYNAME}' not locked");
735  return undef;
736  }
737 
738  if ($self->{CarrierDetect}!~/off/i
739  && $self->carrier($self->{CarrierDetect})) {
740  $self->{LOG}->do('debug',
741  "toggling DTR to hang up Modem '$self->{MYNAME}'")
742  if $self->{DEBUG};
743  $self->pulse_dtr_off(500);
744  }
745 
746  return 1;
747 }
748 
749 =item unlock()
750 
751 Unlock a modem.
752 
753 Emits C<undef> only if the modem is not locked.
754 
755 =cut
756 
757 # give up everything
758 sub unlock
759 {
760  my $self = shift;
761 
762  unless (defined $self->{LOCKFILE}) {
763  $self->{LOG}->do('crit', "unlock: Modem '$self->{MYNAME}' not locked");
764  return undef;
765  }
766 
767  $self->hangup();
768 
769  if (defined($self->{LOCKFILE})) {
770  $self->{LOG}->do('debug', "unlocking Modem '$self->{MYNAME}'")
771  if $self->{DEBUG};
772  unlink($self->{LOCKFILE});
773  undef $self->{LOCKFILE};
774  }
775 }
776 
777 =item DESTROY()
778 
779 Cleanup code, implicitly executed.
780 
781 =cut
782 
783 # what happens when we get destroyed
784 sub DESTROY
785 {
786  my $self = shift;
787 
788  # since I call "close", a weird double-destroy happens, need these
789  # for final logging
790  #my $log=$self->{LOG};
791  #my $name=$self->{MYNAME};
792  #my $debug=$selft->{DEBUG};
793 
794  $self->{LOG}->do('debug', "Modem Object '$self->{MYNAME}' being destroyed")
795  if $self->{DEBUG};
796 
797  $self->unlock() if defined $self->{LOCKFILE};
798 
799  # call parent destructor
800  $self->SUPER::DESTROY;
801 
802  $self->{LOG}->do('debug', "Modem Object '$self->{MYNAME}' destroyed")
803  if $self->{DEBUG};
804 }
805 
806 =for developers: Add new functions here.
807 
808 =back
809 
810 =cut
811 
812 # extra bits...
813 sub HexDump
814 {
815  my ($self, $text) = @_;
816 
817  my $str = $self->HexStr($text);
818 
819  $self->{LOG}->do('debug', "len %d: %s", length($text), $str);
820 }
821 
822 sub HexStr
823 {
824  my $self = shift;
825  my $text = shift;
826  my ($str, @chars);
827 
828  if (defined($text)) {
829  @chars = split // => $text;
830  for my $i (@chars) {
831  if ($i !~ /^[\040-\176]$/) {
832  $str .= sprintf("{0x%02X}", ord($i));
833  } else {
834  $str .= $i;
835  }
836  }
837  } else {
838  $str .= "-undef-";
839  }
840 
841  return $str;
842 }
843 
844 1; # This is a module
845 
846 __END__
847 
848 =head1 AUTHOR
849 
850 Kees Cook <kees@outflux.net>
851 
852 =head1 BUGS
853 
854 This needs more docs; DEFINITELY!
855 
856 =head1 SEE ALSO
857 
858 Man pages: L<perl>, L<sendpage>.
859 
860 Module documentation: L<Sendpage::KeesConf>, L<Sendpage::KeesLog>,
861 L<Sendpage::PagingCentral>, L<Sendpage::PageQueue>, L<Sendpage::Page>,
862 L<Sendpage::Recipient>, L<Sendpage::Queue>
863 
864 =head1 COPYRIGHT
865 
866 Copyright 2000-2003 Kees Cook.
867 
868 This library is free software; you can redistribute it and/or
869 modify it under the same terms as Perl itself.
870 
871 =cut