#!/usr/bin/perl
use warnings;
use strict;
use Glib qw/TRUE FALSE/;
use Gtk2 '-init';

# create a new window
my $window = Gtk2::Window->new('toplevel');
$window ->signal_connect( "destroy" => sub { Gtk2->main_quit; } );


my $vbox = Gtk2::VBox->new( FALSE, 0 );
$window->add($vbox);
$vbox->set_border_width(2);

my $button = Gtk2::Button->new_from_stock('gtk-close');
my $button1 = Gtk2::Button->new_from_stock('gtk-close');
my $button2 = Gtk2::Button->new_from_stock('gtk-close');

$button->set_label('uh oh lost icon'); #won't work

# sub by muppet
find_and_set_label_in ($button2->child, "This worked");

$button->signal_connect( "clicked" => \&callback, "cool button" );
$button1->signal_connect( "clicked" => \&callback, "cool button1" );
$button2->signal_connect( "clicked" => \&callback, "cool button2" );

$vbox->pack_start( $button, FALSE, FALSE, 0 );
$vbox->pack_start( $button1, FALSE, FALSE, 0 );
$vbox->pack_start( $button2, FALSE, FALSE, 0 );

$window->show_all();

Gtk2->main;
##################################################
# our usual callback function
sub callback {
my $widget = shift;
my $data   = shift;
printf "Hello again - %s was pressed\n", $data;
}
##################################################

sub find_and_set_label_in {
 # recursive muppet magic
 my ($widget, $text) = @_;
 print "@_\n";
 if ($widget->isa (Gtk2::Container::)) {
       $widget->foreach (sub { find_and_set_label_in ($_[0], $text); }
+);
    } elsif ($widget->isa (Gtk2::Label::)) {
       $widget->set_text ($text);
   }
}
[download]

X   4143  61
Y   51    1325
Z   543   1543
[download]

Y   51    1325
X   4143  61
Z   543   1543
[download]

use strict;
use warnings;
use Data::Dumper;

my @sorted = map {pop @$_
} sort {
  $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1]
} map {
  [
   (sort {
     $a <=> $b
   } @$_[1,2]),$_
  ]
} map { [split /\s+/] } <DATA>;

print Dumper \@sorted;

__DATA__
A 15134 135
B 413 6161
C 33 16199
D 16141345 135
[download]

# Usage: my $iter = DbiSthIterator->new($sth1, $sth2, ...);
#
#        while ($row = $iter->next()) {
#            ...undef signals the exhaustion of the iterator
#        }

package DbiSthIterator;

sub new {
    my ($class, @sth) = @_;
    bless \@sth, $class;
}

sub next {
    my $self = shift;

    while (my $sth = shift(@$self)) {
        if (my $row = $sth->fetchrow_hashref()) {
            push(@$self, $sth);
            return $row;
        } else {
            # Leaving the exhausted $sth out of the queue
            next;
        }
    }

    undef;
}

1;
[download]

use LWP::UserAgent;
use URI;

my $response = LWP::UserAgent->new->get('http://search.cpan.org/');

$html = $response->content;
$base = $response->base;

# RegEx converts all links in $html to absolute URLs
$html =~ s/<(.*?)(href|src|action|background)\s*=\s*("|'?)(.*?)\3((\s+
+.*?)*)>/"<".$1.$2."=\"".URI->new_abs($4,$base)->as_string."\"".$5.">"
+/eigs;

print $html;
[download]

# $client should contain a SOAP::Lite client that uses HTTP/HTTPS

# Cache up to 10 connections
my $max_connections = 10;

# Retrieve the HTTP Transport object.
my $transport = $client->transport();
# Use LWP::UserAgent's conn_cache() method.
$transport->conn_cache({ total_capacity => $max_connections });
[download]

#!/usr/bin/perl -wl

use strict;

#######################
## string numerifier ##
#######################

# SI prefix to exponent value conversion table
my %SI = (
             Y => +24, # yotta
             Z => +21, # zetta
             E => +18, # exa
             P => +15, # peta
             T => +12, # terra
             G => +9,  # giga
             M => +6,  # mega
             k => +3,  # kilo
             K => +3,  # kilo
             "" => 0,  # default is no SI prefix
             m => -3,  # milli
             u => -6,  # micro
             n => -9,  # nano
             p => -12, # pico
             f => -15, # femto
             a => -18, # atto
             z => -21, # zepto
             y => -24, # yocto
         );

sub num
{
    my ($numstr) = @_;

    # string must contain digit
    if ($numstr =~ /\d/)
    {
        # clean string for best chance at numerification
        my ($sign, $exponent, $siprefix) = ("+", 0, "");
        if ($numstr =~ /^[^.]*\d/) # does first digit appear before po
+tential decimal point?
        {
            $numstr =~ s/^.*?([+-]?)(\d+[.]?\d*)(?:[eE]([+-]?\d+))?([Y
+ZEPTGMkKmunpfazy])?.*/$2/;
            $sign     = $1 if $1;
            $exponent = $3 if $3;
            $siprefix = $4 if $4;
        }
        else
        {
            $numstr =~ s/^.*?([+-]?)(\d*[.]?\d+)(?:[eE]([+-]?\d+))?([Y
+ZEPTGMkKmunpfazy])?.*/$2/;
            $sign     = $1 if $1;
            $exponent = $3 if $3;
            $siprefix = $4 if $4;
        }

        # convert SI prefixes -- example: ".16E2m" => ".16e-1" => 0.01
+6
        if ($exponent || $siprefix)
        {
            $exponent += $SI{$siprefix};
            $numstr   .= "e".$exponent;
        }

        # numerify string according to nearest sign
        {
            no warnings 'numeric';
            $numstr = -+-$numstr;                 # high-precedence nu
+merifier
            $numstr =   -$numstr if $sign eq "-"; # negative if last s
+ign is "-"
        }
    }
    else
    {
        $numstr = undef;
    }

    return($numstr);
}

##############
# test cases #
##############

print "|".num("+-- 123.mA")."|";          # output: "|0.123|"
print "|".num(" -+--.15e4u99..99.0")."|"; # output: "|-0.0015|"
print "|".num(" -+-- 789. G5e2")."|";     # output: "|789|"

print "|".(1e-6 == num("1e-6"))."|"; # output: "|1|"
print "|".(1e-6 == num("1e3n"))."|"; # output: "|1|"
print "|".(1e-6)."|".(1e3*1e-9)."|"; # output: "|1e-06|1e-06|"
print "|".(1e-6 == 1e3*1e-9)."|";    # output: "||"  -- low-level FP l
+imitation, perhaps with C's strtod()
[download]

#!/usr/bin/perl
use warnings;
use strict;
use Glib;
use Term::ReadKey;
use threads;
#use threads::shared;

$|++;
ReadMode('cbreak');

# works non-blocking if read stdin is in a thread
my $count = 0;
my $thr = threads->new(\&read_in)->detach;

my $main_loop = Glib::MainLoop->new;
my $timer  = Glib::Timeout->add (1000, \&timer_callback, undef, 1 );
# can also have filehandle watches
#my $watcher;
#$watcher = Glib::IO->add_watch( fileno( $pty ), ['in', 'hup'], \&call
+back);

$main_loop->run;
ReadMode('normal'); # restore normal tty settings

sub timer_callback{
     #do stuff
     $count++;
     print "\n$count\n";
    return 1;
}

sub read_in{
        while(1){
         my $char;
         if (defined ($char = ReadKey(0)) ) {
            print "\t\t$char->", ord($char),"\n";    
            #process key presses here
            #if($char eq 'q'){exit}
            if(length $char){exit}  # panic button on any key :-)
                
            }
          }
}

__END__
[download]

#!/usr/bin/perl
use warnings;
use strict;
use Glib qw(TRUE FALSE);
use Gtk2 -init;
use IO::Socket;

my $name = shift || 'anon';
my $host = 'localhost';
my $port = 12345;
my $socket;

# make entry widget larger, colored text
Gtk2::Rc->parse_string(<<__);

style "my_entry" {
  font_name ="arial 30"
  text[NORMAL] = "#FF0000"
}

style "my_text" {
font_name ="sans 12"
text[NORMAL] = "#FFAA00"
base[NORMAL] = "#000000"   
GtkTextView::cursor-color = "red"
}
style "my_cursor"{
fg[NORMAL] = "#FF0000"
}

widget "*Text*" style "my_text"
widget "*Entry*" style "my_entry"
__

my $window = Gtk2::Window->new;
$window->signal_connect( delete_event => sub { exit } );
$window->set_default_size( 400, 300 );

my $vbox = Gtk2::VBox->new;
$window->add($vbox);

my $scroller = Gtk2::ScrolledWindow->new;
$vbox->add($scroller);
my $textview = Gtk2::TextView->new;
$textview ->set_editable (0); #read-only text
$textview ->can_focus(0);     #
my $buffer   = $textview->get_buffer;
$buffer->create_mark( 'end', $buffer->get_end_iter, FALSE );
$buffer->signal_connect(
    insert_text => sub {
        $textview->scroll_to_mark( $buffer->get_mark('end'), 0.0, TRUE
+, 0,
            0.5 );
    }
);
$scroller->add($textview);


my $entry = Gtk2::Entry->new();

$vbox->pack_start( $entry, FALSE, FALSE, 0 );
$vbox->set_focus_child ($entry); # keeps cursor in entry
$window->set_focus_child ($entry); # keeps cursor in entry

# allows for sending each line with an enter keypress
my $send_sig = $entry->signal_connect ('key-press-event' => sub {
         my ($widget,$event)= @_;
         if( $event->keyval() == 65293){  # a return key press
                my $text = $entry->get_text;
        if(defined $socket){ print $socket $name.'->'. $text, "\n";}
             $entry->set_text('');
             $entry->set_position(0);
     }
   });

#If you store the ID returned by signal_connect, you can temporarily
#block your signal handler with
#  $object->signal_handler_block ($handler_id)
#    and unblock it again when you're done with
##        $object->signal_handler_unblock ($handler_id).

# we want to block/unblock the enter keypress depending
# on the state of the socket
$entry->signal_handler_block($send_sig); #not connected yet
$entry->set_editable(0);

my $button = Gtk2::Button->new('Connect');
$button->signal_connect( clicked => \&init_connect );

$vbox->pack_start( $button, FALSE, FALSE, 0 );
$window->show_all;
Gtk2->main;
exit;


sub init_connect{

      $socket = IO::Socket::INET->new(
          PeerAddr => $host,
          PeerPort => $port,
          Proto    => 'tcp',
       );
       
       if( ! defined $socket){ 
            my $buffer = $textview->get_buffer;
            $buffer->insert( $buffer->get_end_iter, 
            "ERROR: Can't connect to port $port on $host: $!\n" );
        return;
        }
      
      #if we have a socket
      $button->set_label('Connected');
      $button->set_state('insensitive');
 
        # install an io watch for this stream and
        # return immediately to the main caller, who will return
        # immediately to the event loop.  the callback will be
        # invoked whenever something interesting happens.
        Glib::IO->add_watch( fileno $socket, [qw/in hup err/], \&watch
+_callback, $socket );

       #turn on entry widget
       $entry->set_editable(1);
       $entry->grab_focus;
       $entry->signal_handler_unblock ($send_sig);
       Gtk2->main_iteration while Gtk2->events_pending; 
}


sub watch_callback {
    my ( $fd, $condition, $fh ) = @_;
    if ( $condition >= 'in' ) {

        # there's data available for reading.  we have no
        my $bytes = sysread( $fh,  my $data, 1024);

        if ( defined $data ) {
            # do something useful with the text.
            my $buffer = $textview->get_buffer;
            $buffer->insert( $buffer->get_end_iter, $data );
        }
    }
    if ( $condition >= 'hup' or $condition >= 'err' ) {

        # End Of File, Hang UP, or ERRor.  that means
        # we're finished.
        
        # stop ability to send 
        $entry->set_editable(0);
        $entry->signal_handler_block ($send_sig);
        
        my $buffer = $textview->get_buffer;
        $buffer->insert( $buffer->get_end_iter, "Server connection los
+t !!\n" );
    
        #close socket
        $fh->close;
        $fh = undef;
                
        #allow for new connection
        $button->set_label('Connect');
        $button->set_sensitive(1);
        $button->grab_focus;
        Gtk2->main_iteration while Gtk2->events_pending; 
    }

    if ($fh) {

        # the file handle is still open, so return TRUE to
        # stay installed and be called again.
        # print "still connected\n";
        # possibly have a "connection alive" indicator
        return TRUE;
    }
    else {

        # we're finished with this job.  start another one,
        # if there are any, and uninstall ourselves. 
        return FALSE;
    }
}

__END__
[download]