Back in the day, I wrote a small call monitor that used TCP port 1012 - the FritzBox sends a CSV-line for each incoming/outgoing call there. Today I would rewrite this using Mojolicious as the event loop, or maybe some other thing, but here is my code. The most interesting part is in dispatch_line, everything else is just setting up the (re)connection to the Growl service and AnyEvent (both of which I don't use anymore ...)

package AnyEvent::FritzBox;
use strict;
use List::MoreUtils qw( zip );
use AnyEvent;
use AnyEvent::Socket;
use AnyEvent::Handle;
use Data::Dumper;
use Scalar::Util qw(weaken blessed);

# Dial C<#96*5*> to enable the TCP call monitor

use vars qw< %indicator_map %field_map >;

%indicator_map = (
    CALL => 'on_call',
    RING => 'on_ring',
    CONNECT => 'on_connect',
    DISCONNECT => 'on_disconnect',
);

%field_map = (
    on_call       => [ qw[ date kind id local_id local_number remote_n
+umber provider ] ],
    on_ring       => [ qw[ date kind id remote_number local_number pro
+vider ] ],
    on_connect    => [ qw[ date kind id local_id remote_number ]],
    on_disconnect => [ qw[ date kind id seconds ]],
);

sub new {
    my ($class, %args) = @_;
    
    $args{ on_call } ||= sub {};
    $args{ on_ring } ||= sub {};
    $args{ on_disconnect } ||= sub {};
    $args{ max_retries } ||= 10; # We always give up after 10 attempts
+ to connect
    $args{ reconnect_cooldown } ||= 2; # Start value for the exponenti
+al falloff

    $args{ current_reconnect } = undef; # we are not (yet) reconnectin
+g
    
    if ($args{ log } && !ref $args{ log }) {
        $args{ log } = sub { print "@_\n" };
    };
    
    my $self = bless \%args => $class;
    my $s = $self;
    my $connected = AnyEvent->condvar;
    my $have_handle = AnyEvent->condvar(cb => sub {
        #$self->log("Have handle");
        $s->setup_handle($self->{ handle });
        $connected->send() if $connected;
        
        # This should be done more elegantly by
        # putting this into the callback of $connected
        my $c = $s->{on_connect};
        unshift @_, $s;
        undef $s;
        goto &{ $c }
           if $c;
    });
    
    if (! $self->{ handle }) {
        $self->{ host } ||= 'fritz.box';
        $self->{ port } ||= 1012;
        
        $self->log("Launching connect");
        $self->connect( $self->{host}, $self->{port}, $have_handle);
    } else {        
        $have_handle->send();
    };
    
    # We are synchronous here in case there is no continuation passed 
+in
    if ($self->{synchronous} or not $self->{on_connect}) {
        $args{ on_connect_fail } = sub { undef $self; $connected->send
+; };
        $connected->recv;
    } else {
        $args{ on_connect_fail } = sub {};
    };
    undef $connected; # clean up stuff held by closure

    $self
};

sub log {
    my $s = shift;
    my $l = $s->{log};
    goto &$l if $l;
};

sub connect {
    my ($self,$host,$port,$connected) = @_;
    $self->log("Connecting to $host:$port");
    tcp_connect $host, $port, sub {
        my ($fh) = @_;
        if (! $fh) {
            $self->log("Couldn't connect to $host:$port");
            $self->timed_reconnect($host,$port,$connected); # launch r
+econnect timer
            return;
        };
        # we got a connection, reset our retry counters
        $self->log("Connected to $host:$port");
        $self->{current_reconnect} = undef;
        $self->setup_handle($fh);
        
        $connected->send();
    };
    return 1
};

sub timed_reconnect {
    my ($self,$host,$port) = @_;
    if (! $self->{current_reconnect}->{timer}) {
        if ($self->{current_reconnect}->{retried}++ < $self->{max_retr
+ies}) {
            # We add a fuzz delay of up to 2 seconds to prevent stampe
+ding herds
            my $cooldown = $self->{reconnect_cooldown} ** $self->{curr
+ent_reconnect}->{retried}
                         + rand(2);
            
            $self->log( "Reconnecting in $cooldown seconds" );
            
            $self->{current_reconnect}->{timer} ||= AnyEvent->timer(af
+ter => $cooldown, cb => sub {
                $self->log( "Reconnecting to $host:$port" );
                
                # Tell ourselves that our callback triggered
                delete $self->{current_reconnect}->{timer};
                my $connected = AnyEvent->condvar();
                $connected->cb(sub { $self->log( "Reconnected" )} );
                $self->connect($host, $port, $connected);
            });
        } else {
            $self->log("Maximum number of reconnects reached");
            $self->{on_connect_fail}->($host,$port);
            die "No connection to $host:$port after $self->{max_retrie
+s}";
        };
    } else {
        $self->log("Already reconnecting");
    };
};

sub setup_handle {
    my ($self,$fh) = @_;
    if (not(blessed $fh and $fh->isa('AnyEvent::Handle'))) {
        $fh = AnyEvent::Handle->new(
            fh => $fh,
        );
    };
    $self->{handle} = $fh;
    
    $self->{ handle }->on_read(sub {
        my $h = $_[0];
        $h->push_read( line => sub {
            #warn "READ: @_";
            $self->dispatch_line(@_);
        });
    });
    
    #weaken $self;
    $self->{ handle }->on_error(sub {
        #warn "[" . __PACKAGE__ . "] socket error: $_[2]";
        $_[0]->destroy;
        # Try to reconnect here, after some timeout
        if ($self) {
            if ($self->{current_reconnect} && 
                $self->{current_reconnect}->{retried} >= $self->{max_r
+etries}) {
                # Well, somebody could hear this, somewhere
                die "Maximum retries ($self->{max_retries}) reached tr
+ying to connect to $self->{host}:$self->{port}";
            };
            $self->timed_reconnect($self->{host}, $self->{port});
        };
    });
};

# Outbound calls: datum;CALL;ConnectionID;LocalExtension;usedNumber;ca
+lledNumber;
# Inbound calls: datum;RING;ConnectionID;callerId;localNumber;
# Connect: datum;CONNECT;ConnectionID;LocalExtension;Number;
# Disconnect: datum;DISCONNECT;ConnectionID;durationInSeconds;
sub dispatch_line {
    my ($self, $handle, $payload) = @_;
    $payload =~ s/\s+$//;
    return unless $payload;
    #warn "<<$payload>>";
    my @info = split /;/, $payload;
    my $arg_handler = $indicator_map{ $info[1] };
    #warn "Checking for \$self->{'$arg_handler'}";
    if (my $handler = $self->{ $arg_handler }) {
        #warn "Triggering '$arg_handler'";
        @_ = ($self, zip @{ $field_map{ $arg_handler } }, @info);
        goto &$handler;
    };
};

1;
[download]