19.3.1. Creating the Hypertext User Interface

The <Leave> callback is even simpler, because we can unconditionally clear the hot tag from the entire text area. Note the shift trick that returns the implicit ROText widget reference.

$t->tagBind(qw/subnet <Leave>/ => sub {
    shift->tagRemove(qw/hot 1.0 end/);
});

$t->tagBind(qw/subnet <Motion>/ => sub {
    my $text = shift;
    my($x, $y) = ($Tk::event->x, $Tk::event->y);
    my $new_hot = $text->index("\@$x,$y linestart");
    if ($new_hot ne $last_hot) {
        $text->tagRemove(qw/hot 1.0 end/);
        $text->tagAdd('hot', $new_hot, "$new_hot lineend");
        $last_hot = $new_hot;
    }
});

As we learned in the previous section, the actual data inserted into the ROText widget comes from a get_subnet_list IPADM command. The do_command subroutine, described later, handles all the busy work concerning the pipe I/O and protocol details, but note that it issues a single, human-legible command and returns the command status and data. Each line of data consists of two tokens: the SDB filename and the Title line from the SDB file. In the following code, each line is tagged with two strings: "subnet" and the SDB filename (the filename has the extension .sdb).

my($status, @subnet_list) = do_command "get_subnet_list\n";
die "Cannot get SDB list" unless  $status =~ /OK/;

foreach (sort numerically @subnet_list) {
    my($sdb, $title) = /^(\S+)\s+(.*)/;
    $t->insert('end', "$title\n", ['subnet', $sdb]);
}

To complete the user interface, we need to invoke the subnet editor when a subnet line is clicked:

$t->tagBind(qw/subnet <ButtonRelease-1>/ => \&open_subnet);

sub open_subnet {

    my($text) = @_;

    my @tags = $text->tagNames('current');
    my $i = lsearch('.*\.sdb', @tags);
    return if $i < 0;
    $text->Busy(-recurse => 1);
    my $id = "$ME\@$HN:$$";
    my(@sdb) = do_command "get_subnet_file $tags[$i] $id\n";
    if ($sdb[0] =~ /Have Lock|Lock Failed/) {
     $text->Subnet(
      -sdb_path  => $tags[$i],
      -sdb       => \@sdb,
      -id        => $id,
      -updatecmd => sub {do_command "put_subnet_file $tags[$i] $id\n", @sdb},
      -cancelcmd => sub {do_command "unl_subnet_file $tags[$i] $id\n"},
     );
    } else {
     $text->messageBox(-message => "SDB Open Error: $sdb[0]",
      -type => 'ok', -bitmap => 'error');
    }
    $text->Unbusy;

} # end open_subnet

19.3.2. The Subnet Widget Edits a Subnet Description

Figure 19-3. The Subnet widget edits an SDB description

The A (address) field is the unqualified IP name of the node. People on the Rubber Band subnet can refer to the print server using this name or the IP number 192.168.128.17. People on other ACME subnets must use either the IP number or include the domain and use the fully qualified IP name, JetDirect3.RubberBand.ACME.Com. The CNAME (canonical name) field is an alias for the node's IP name. The MX (mail exchange) field typically points to a mail server that handles mail on behalf of the node; it's not relevant in this case. The Comments field is just that.

As the balloon help suggests, the subnet administrator can type a search string in any node field to perform a search. Once a node entry is loaded, he makes his changes and clicks Apply. Or, to make a new node entry, he clicks on an available IP number in the Listbox on the right, moving it from the free list to the edit area, configures the node, and applies the changes. When complete, he can either update the subnet with his changes (put_subnet_file) or cancel them all (unl_subnet_file).

my $callback = sub {
    shift->Store(shift);
    $cw->{Subnet_Changes}++;
};

Tie::Watch->new(-variable => \$title, -store => $callback);

19.3.3. Starting the IPADM Helper Task

As its first task, ipadmh attempts to connect to the daemon, ipadmd, and pipes us an unsolicited message indicating whether or not the connect was successful. Calling do_command without a command reads this message for us.

Finally, note the dubious use of a signal handler to catch a SIGPIPE error. Generally, mixing signals with Perl/Tk causes unexpected application crashes, but in this case, losing contact with the helper is, for all intents and purposes, fatal, and this lets us exit gracefully.

sub start_ipc_helper {

    $SIG{PIPE} = sub {print STDERR "ipadmh pipe failure.\n"; exit};

    pipe CR, PW or die "cr/pw pipe $!";
    pipe PR, CW or die "pr/cw pipe $!";

    if ($PID = fork) { # parent, ipadm/Tk
        close CR;
        close CW;
        PW->autoflush(1);
    } elsif (defined $PID) { # child, exec ipadmh
        close PR;
        close PW;
        open STDIN,  "<&CR" or die "STDIN  open $!";
        open STDOUT, ">&CW" or die "STDOUT open $!";
        open STDERR, ">&CW" or die "STDERR open $!";
        STDOUT->autoflush(1);
        STDERR->autoflush(1);
        exec("./ipadmh", $DAEMON_HOST, $DAEMON_PORT) or die "exec $!";
        die "exec warp $!";
    } else {
        die "fork $!";
    } # ifend fork

    my(@stat) = do_command undef;    # did helper make a connection?
    return if $stat[0] =~ /Connect OK/;

    $MW->messageBox(-message => "Cannot connect to remote IPADM daemon " .
        "$DAEMON_HOST:$DAEMON_PORT.  Please try again later.",
        -title => 'Daemon is Dead', -icon  => 'warning',
        -type => 'OK');
    fini;

} # end start_ipc_helper

sub fini {
    kill 'SIGTERM', $PID;
    exit;
}

19.3.4. fileevent Keeps ipadm Happy

sub do_command {

    # Issue a single IPADM command and wait for a reply.  Using
    # pipes and fileevent( ) allows X11 events to continue flowing.

    pipe_out @_;
    return pipe_in;

} # end do_command

Recall that ipadm uses this code to get a list of subnets:

my($status, @subnet_list) = do_command "get_subnet_list\n";
die "Cannot get SDB list" unless  $status =~ /OK/;

do_command's helper pipe_out appends the terminating string, $EOF, to the outgoing data, then registers a callback that's invoked when the output pipe is writable. Because we're coding with use strict in effect, we cannot give fileevent a bare file handle but must use a reference to a glob instead. The callback outputs its data, including the $EOF, using syswrite, at which time it increments $wait. Meanwhile, waitVariable has logically suspended us, pending a change in $wait, at which time the writable callback is canceled.

sub pipe_out {

    # Issue an IPADM command by syswrite-ing all the data plus
    # the terminating $EOF.

    return unless defined $_[0];

    my($bytes, $offset, $sysdata, $sysstat, $wait);

    $sysdata = join '', @_, "$EOF\n";
    $bytes = length $sysdata;
    $offset = 0;

    $MW->fileevent(\*PW, 'writable' => sub {

        while ($bytes > 0) {
            $sysstat = syswrite PW, $sysdata, $bytes, $offset;
            die "ipadm: syswrite error $!" unless defined $sysstat;
            $bytes  -= $sysstat;
            $offset += $sysstat;
        }
        $wait++;

    });

    $MW->waitVariable(\$wait);
    $MW->fileevent(\*PW, 'writable' => '');

} # end pipe_out

sub pipe_in {

    # Now that the IPADM command has been issued, keep sysread-ing
    # until the $EOF string is read, and return all the accumulated
    # data, excluding $EOF.

    my(@data, $sysbuf, $sysdata, $sysstat, $wait);

    $MW->fileevent(\*PR, 'readable' => sub {

        if ( $Tk::VERSION  le '800.015' ) {
            $sysbuf = <PR>;
        } else {
            $sysstat = sysread PR, $sysbuf, 4096;
            die "ipadm: sysread error $!" unless defined $sysstat;
        }
        $sysdata .= $sysbuf;
        if ($sysdata =~ /$EOF$/s) {
            @data = split /\n/, $sysdata;
            $#data--;        # throw $EOF away
            $wait++;         # unblock waitVariable( )
        }

    });

    $MW->waitVariable(\$wait);
    $MW->fileevent(\*PR, 'readable' => '');

    @data;

} # end pipe_in