"Fossies" - the Fresh Open Source Software Archive

Member "sendpage-1.001001/lib/Sendpage/Modem.pm" (3 Jan 2008, 21775 Bytes) of package /linux/privat/old/sendpage-1.001001.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Modem.pm" see the Fossies "Dox" file reference documentation.

    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