File Coverage

blib/lib/Tk/QuickTk.pm

Criterion	Covered	Total	%
statement	27	29	93.1
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	36	38	94.7

#                  file:  Tk/QuickTk.pm
#
#   Copyright (c) 2000, 2011 John Kirk. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
#   The latest version of this module should always be available
# at any CPAN (http://www.cpan.org) mirror, or from the author:
#              http://perl.dystanhays.com/jnk

package Tk::QuickTk;
use warnings;
use strict;

BEGIN {
    use Exporter ();
    use AutoLoader ();
    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $VERSION     = '0.92';
    @ISA         = qw(Exporter AutoLoader);
    #Give a hoot don't pollute, do not export more than needed by default
    @EXPORT      = qw();
    @EXPORT_OK   = qw(app createwidget);
    %EXPORT_TAGS = ();
}

require 5.002;     # version of Perl
use Carp;
use FileHandle;    # nice to easily have filehandles as plain variables
use Tk;

# initial hash to bless as content of QuickTk instance:
my %proto=('menutypes'=>{'c'=>'command','k'=>'checkbutton','-'=>'separator',
                         'm'=>'cascade','r'=>'radiobutton',                  },
             'widgets'=>{                                                    },);

# EXPORT_OK routines:
sub app;
sub createwidget;

# internal use only routines:
sub _loadwidget;
sub _getargs;
sub _docode;
sub _bindevent;
sub _loadmenitm;
sub _getttl;
sub _getcmd;
sub _getsub;
sub _getini;

# instance constructor routine:
sub new { my ($that,$spec,$lname,$genonly)=@_;
  my $class=ref($that)||$that;
  my $me={_prop=>\%proto,%proto,}; # initial hash from prototype and ref. to it
  bless $me,$class;
  if(defined $genonly) { $$me{genonly}=$genonly; }
  if(defined $lname) {
    $$me{lname}=$lname;
    $$me{lfh}=new FileHandle ">$lname";
  }
  if(defined $spec) { # a spec was passed in; load it
    my $specref;
    if(!ref $spec) { # it's a filename (also handle case: '')
      croak "can't read QuickTk spec file: $spec\n" unless -f $spec && -r _;
      use Text::TreeFile;
      my $hier=Text::TreeFile->new($spec);
      $specref=$$hier{top};
    } elsif(ref($spec) eq 'Text::TreeFile') {
      $specref=$$spec{top};
    } elsif(ref($spec) eq 'ARRAY' and scalar @$spec==2 and
            !ref $$spec[0] and ref($$spec[1]) eq 'ARRAY') {
      $specref=$spec;
    } else {
      croak "can't make a new Tk::QuickTk from spec: $spec\n";
    }
    _loadwidget($me,$specref);
    if(exists $$me{inicode} and defined $$me{inicode} and $$me{inicode}) {
      my $err=_docode($me,0,$$me{inicode});
      if($err) {
        croak "failed to execute initialization code\n";
      }
    }
  }
  return $me;
}

# EXPORT_OK; starts up Tk main loop; looks for script file name on commandline
#   seems to go into Tk's MainLoop even if no script:  Better diagnostics?
sub app { my ($gen,$gname)=@_; # args in case code generation to be saved
  my $name=$ARGV[0]
    or croak "Tk::QuickTk::app() found no filename on the command line\n";
  my $iname=$name;
  my $oname;
  if(defined $gen and $gen ne 'nogen') {
    $oname=(defined $gname)?$gname:$name.'.pl';
    print STDERR "Tk::QuickTk::app() logging generated perl-tk code";
    print STDERR " to file: $oname\n";
  }
  my $app=(defined $oname)?Tk::QuickTk->new($iname,$oname)
                          :Tk::QuickTk->new($iname);
  MainLoop;croak "fell through MainLoop";
}

# EXPORT_OK; creates a widget on the fly (when it was defined but not created at startup
#
sub createwidget {
  my ($gl,$arg,$specname)=@_;
  my ($code,$err,$menidx,$ret);
  my %mt=%{$$gl{menutypes}};
  my $spec=$$gl{widgets}{$specname};
  croak "couldn't find \"$specname\" widget to create\n" unless defined $spec;
  my ($level,$momname,$momidx,$name,$type,$cfg,$pak,$children)=@$spec;
  for($name,$type,$cfg,$pak) {
    s/\$(\d+)/$$arg[$1-1]/g;
  }
  if(defined $momidx) { # this is a menu item
    $code="\$\$w{${momname}_${momidx}_$$arg[0]}=\$\${momname}->$mt{$type}";
    if($type ne '-') {
      $code.="(-label=>\"$name\")";
    }
    $err=_docode($gl,$level,$code);
    $code='';
    croak "failed to create menu item $momname/${name}_$$arg[0]($momidx)\n" if ($err);
    if($cfg) {
      $code="\$\$w{momname}_${momidx}_$$arg[0]}->configure($cfg)";
      $err=_docode($gl,$level,$code);
      $code='';
      if($err) {
        croak "failed to configure $momname/$name(${momidx}_$$arg[0])\n";
      }
    }
    if(@$children) {
      $code="\$\$w{${momname}_${momidx}_$$arg[0]_menu}";
      $code.="=\$\$w{$momname}->Menu";
      $err=_docode($gl,$level,$code);
      $code='';
      if($err) {
        croak "failed to create Menu: ${momname}_${momidx}_$$arg[0]_menu\n";
      }
      $code="\$\$w{${momname}_${momidx}_$$arg[0]}->configure(";
      $code.="-menu=>\$\$w{${momname}_${momidx}_$$arg[0]_menu})";
      $err=_docode($gl,$level,$code);
      my $errname="${momname}_$momidx/${momname}_${momidx}_$$arg[0]_menu";
      if($err) {
        croak "failed to configure menu item $errname\n";
      }
    }
    $menidx=0;
    for(@$children) {
      _loadmenitm $gl,$_,$level+1,"${momname}_${momidx}_$$arg[0]_menu",$menidx;
      ++$menidx;
    }
  } else { # this is an ordinary widget
    $code="\$\$w{${name}_$$arg[0]}=\$\$w{$momname}->$type";
    $code.="($cfg)" if($cfg);
    $err=_docode($gl,$level,$code);
    $code='';
    if($err) {
      croak "failed to create ${name}_$$arg[0]: $momname/$type\n";
    }
    if($type eq 'Menubutton') {
      $code="\$\$w{${name}_$$arg[0]_menu}=\$\$w{${name}_$$arg[0]}->Menu";
      $err=_docode($gl,$level,$code);
      $code='';
      if($err) {
        croak "failed to create Menu ${name}_$$arg[0]_menu for Menubutton ${name}_$$arg[0]\n";
      }
      $code="\$\$w{${name}_$$arg[0]}->configure(-menu=>\$\$w{${name}_$$arg[0]_menu})";
      $err=_docode($gl,$level,$code);
      $code='';
      if($err) {
        croak "failed to configure Menubutton ${name}_$$arg[0]\n";
      }
    }
    $menidx=0;
    for(@$children) {
      if($type ne 'Menubutton') {
        if(substr($$_[0],0,1) ne '<') {
          _loadwidget $gl,$_,$level+1,"${name}_$$arg[0]";
        } else {
          _bindevent $gl,$_,$level+1,"${name}_$$arg[0]";
        }
      } else {
        _loadmenitm $gl,$_,$level+1,"${name}_$$arg[0]_menu",$menidx;
        ++$menidx;
      }
    }
    return if($pak=~/^nopack/);
    $ret=($pak=~s/^(pack|place|grid),//)?$1:'pack';
    $code="\$\$w{${name}_$$arg[0]}->$ret($pak)";
    $err=_docode($gl,$level,$code);
    $code='';
    if($err) {
      croak "failed to pack ${name}_$$arg[0]\n";
    }
  }

}

sub _loadwidget {
  my ($gl,$spec,$level,$momname)=@_;
  my ($cfg,$pak,$idx,$ret,$cre,$code,$err);
  my ($localname,$type,$tail)=split ' ',$$spec[0],3;
  $momname='' if not defined $momname;
  my $name=$momname.$localname;
  $level=0 if not defined $level;
  if($level==0) {
    $type='MainWindow' if $type=~/^(Toplevel|Frame)$/;
    if($type ne 'MainWindow') {
      croak "Top level widget must be \"MainWindow\", not \"$type\"\n";
    }
    ($cre,$cfg,$pak)=_getargs($gl,0,$tail,{'ttl'=>\&_getttl,
                                           'ini'=>\&_getini,});
    if($cre ne 'create') {
      carp "ignoring 'nocreate' for MainWindow...\n";
    }
    if($pak and $pak ne 'nopack') {
      carp "Packing options ($pak) for MainWindow are being ignored...\n";
    }
    $code="\$\$w{$name}=$type->new";
    $err=_docode($gl,$level,$code);
    $code='';
    if($err) {
      croak "failed to open MainWindow\n";
    }
    if($cfg) {
      $code="\$\$w{$name}->configure($cfg)";
      $err=_docode($gl,$level,$code);
      $code='';
      if($err) {
        croak "failed to configure MainWindow\n";
      }
    }
    for(@{$$spec[1]}) {
      if(substr($$_[0],0,1) ne '<') {
        _loadwidget $gl,$_,$level+1,$name;
      } else {
        _bindevent $gl,$_,$level+1,$name;
      }
    }
    return;
  }
  if($type eq 'MainWindow') {
    $type='Toplevel';
  }
  if($type eq 'Toplevel') {
    ($cre,$cfg,$pak)=_getargs($gl,0,$tail,{'ttl'=>\&_getttl,});
  } elsif($type eq 'Menu') {
    ($cre,$cfg,$pak)=_getargs($gl,0,$tail,{});
  } else {
    ($cre,$cfg,$pak)=_getargs($gl,1,$tail,{'cmd'=>\&_getcmd,
                                           'sub'=>\&_getsub,});
  }
  if($cre ne 'create') {
    $$gl{widgets}{$name}=
      [$level,$momname,undef,$name,$type,$cfg,$pak,$$spec[1]];
    return;
  }
  $code="\$\$w{$name}=\$\$w{$momname}->$type";
  $code.="($cfg)" if($cfg);
  $err=_docode($gl,$level,$code);
  $code='';
  if($err) {
    croak "failed to create $name: $momname/$type\n";
  }
  if($type eq 'Menubutton') {
    $code="\$\$w{${name}_menu}=\$\$w{$name}->Menu";
    $err=_docode($gl,$level,$code);
    $code='';
    $code="\$\$w{$name}->configure(-menu=>\$\$w{${name}_menu})";
    $err=_docode($gl,$level,$code);
    $code='';
    if($err) {
      croak "failed to configure Menubutton\n";
    }
  }
  $idx=0;
  for(@{$$spec[1]}) {
    if($type ne 'Menubutton') {
      if(substr($$_[0],0,1) ne '<') {
        _loadwidget $gl,$_,$level+1,$name;
      } else {
        _bindevent $gl,$_,$level+1,$name;
      }
    } else {
      _loadmenitm $gl,$_,$level+1,"${name}_menu",$idx;++$idx;
    }
  }
  return if($pak=~/^nopack/);
  $ret=($pak=~s/^(pack|place|grid),//)?$1:'pack';
  $code="\$\$w{$name}->$ret($pak)";
  $err=_docode($gl,$level,$code);
  $code='';
  if($err) {
    croak "failed to create menu item $momname/$name\n";
  }
}

sub _getargs {
  my ($gl,$pakq,$inp,$cmds)=@_;
  my ($opt,$sep,$val,$cdr,@cfg,@pak);
# called five places: four in loadwidget() and one in loadmenitm()
  my $create=1;
  if($pakq) {
    while($inp!~/^\s*$/) {
      ($opt,$sep,$cdr)=($inp=~/^([^ :]*)([ :])(.*)$/);
      if(!defined $sep) {
        $opt=$inp;
        $inp='';
        $val='-empty-';
      } elsif($sep eq ' ') {
        $val='-empty-';
        $cdr=~s/^\s+//;
        $inp=$cdr;
      } else {
        ($val,$inp)=($cdr=~/^[']([^']*)[']\s*(.*)$/);
        if(!defined $val) {
          if(substr($cdr,0,1) eq ' ') {
            $val='';$cdr=~s/^\s+//;
            $inp=$cdr;
          } else {
            ($val,$inp)=split ' ',$cdr,2;
          }
        }
      }
      last if $opt eq '';

      if(!defined $val or $val eq '' or $val eq '-empty-') { # no $val
        if($opt eq 'nocreate') {
          $create=0;
        } elsif($opt=~/^nopack|pack|place|grid$/) {
          unshift @pak,$opt;
        } else {
        push @pak,"-$opt=>\"\"";
        }
      } else {                                              # we have $val
        if($val=~/^\$\$/) {
          push @pak,"-$opt=>$val";
        } elsif($val=~/^\$\d+/) {
          push @pak,"-$opt=>$val";
        } elsif($val=~/^\$/) {
          push @pak,"-$opt=>".'$$gl{'.substr($val,1).'}';
        } elsif($val=~/^\\/) {
          push @pak,"-$opt=>".'\\$$gl{'.substr($val,1).'}';
        } elsif($val eq "''") {
          push @pak,"-$opt=>$val";
        } elsif($val=~/^\[.*\]$/) {
          push @pak,"-$opt=>$val";
        } else {
          push @pak,"-$opt=>\"$val\"";
        }
      } # end of actions for a $val that is present
    } # end of loop on packing options
  } # end of stuff to do if this widget allows packing
  while(defined $inp and $inp!~/^\s*$/) {
    ($opt,$sep,$cdr)=($inp=~/^([^ :]*)([ :])(.*)$/);
    if(!defined $sep) {
      $opt=$inp;
      $inp='';
      $val='-empty-';
    } elsif($sep eq ' ') {
      $val='-empty-';
      $cdr=~s/^\s+//;
      $inp=$cdr;
    } else {
      ($val,$inp)=($cdr=~/^["]([^"]+)["]\s*(.*)$/) or
      ($val,$inp)=($cdr=~/^[']([^']+)[']\s*(.*)$/) or
      ($val,$inp)=($cdr=~/^([[][^\]]+[\]])\s*(.*)$/);
    }

    if(exists $$cmds{$opt}) {
      if(!defined $val) {
        $val=$cdr;
        $inp='';
      }
      $val='' if $val eq '-empty-';
# The following is subtle or complicated, due to the extra indirection
      ($opt,$val)=&{$$cmds{$opt}}($gl,$opt,$val);
    } else {
      if(!defined $val) {
        if(substr($cdr,0,1) eq ' ') {
          $val='';
          $cdr=~s/^\s+//;
          $inp=$cdr;
        } else {
          ($val,$inp)=split ' ',$cdr,2;
        }
        if(!defined $val) {
          $val=$cdr;
          $inp='';
        }
      }

      if(defined $val and $val ne '') {
        if($val eq '-empty-') {
          $val='';
        } elsif($val=~/^\$\$/) {
          # leave $val alone
        } elsif($val=~/^\\\$\$/) {
          # leave $val alone
        } elsif($val=~/^\$\d+/) {
          # leave $val alone
        } elsif($val=~/^\$/) {
          $val='$$gl{'.substr($val,1).'}';
        } elsif($val=~/^\\/) {
          $val='\\$$gl{'.substr($val,1).'}';
        } elsif($val ne "''" and $val!~/^\[.*\]$/
            and $val!~/^\'.*\'$/ and $val!~/^\".*\"$/) {
          $val="\"$val\"";
        }
      }
    }
    last if !defined $opt or $opt eq '';
    push @cfg,($val ne '')?"-$opt=>".$val:"\"$opt\"";
  }
  return ($create?'create':'nocreate',
          join(',',@cfg),
          $pakq?join(',',@pak):'nopack');
}

sub _docode {
  my ($gl,$level,$code)=@_;
  $code.=";\n";
  my $w=$$gl{widgets};
  $$gl{lfh}->print('  'x$level,$code) if(exists $$gl{lfh});
  $code.="1;\n";
  return undef if $$gl{genonly};
  my $ret=eval $code;
  carp $@ if $@;                    # $@:  EVAL_ERROR (msg or '')
  $code='';
  return $@;
}

sub _bindevent {
  my ($gl,$spec,$level,$momname)=@_;
  my ($event,$act)=split ' ',$$spec[0],2;
  my ($code,$err);
  $code="\$\$w{$momname}->bind(\'$event\'=>$act)";
  $err=_docode($gl,$level,$code);
  $code='';
  if($err) {
    croak "failed to bind: $event: $err\n";
  }
}

sub _loadmenitm {
  my ($gl,$spec,$level,$momname,$momidx)=@_;
  my ($localname,$name,$type,$tail,$code,$err,$label);
  my $trans=1;
  my %mt=%{$$gl{menutypes}};
  ($localname,$type,$tail)=split ' ',$$spec[0],3;
  $name=$momname.$localname;
  if($type!~/^[-cmrk]$/) { $trans=0;
    if($type!~/^separator|command|cascade|radiobutton|checkbutton$/i) {
      croak "unrecgnized menu item type: $type\n";
    }
  }
  my ($cre,$cfg,$pak)=_getargs($gl,0,$tail,{'cmd'=>\&_getcmd,
                                            'sub'=>\&_getsub,});
  if($cre ne 'create') {
    $$gl{widgets}{"${momname}_$momidx"}=
      [$level,$momname,$momidx,$name,$type,$cfg,$pak,$$spec[1]];
    return;
  }
  $code="\$\$w{${momname}_$momidx}=\$\$w{$momname}->";
  $code.=$trans?$mt{$type}:$type;
  if($type ne '-') {
    $cfg=~s/(-label=>[^,]+),?//;
    croak "menu item $name has no label\n" if not defined $1;
    $code.="($1)";
  }
  $err=_docode($gl,$level,$code);
  $code='';
  croak "failed to create menu item $momname/$name($momidx)\n" if($err);
  if($cfg) {
    $code="\$\$w{${momname}_$momidx}->configure($cfg)";
    $err=_docode($gl,$level,$code);
    $code='';
    if($err) {
      croak "failed to configure $momname/$name($momidx)\n";
    }
  }
  if(@{$$spec[1]}) {
    $code="\$\$w{${momname}_${momidx}_menu}";
    $code.="=\$\$w{$momname}->Menu";
    $err=_docode($gl,$level,$code);
    $code='';
    if($err) {
      croak "failed to create Menu: ${momname}_${momidx}_menu\n";
    }
    $code="\$\$w{${momname}_$momidx}->configure(";
    $code.="-menu=>\$\$w{${momname}_${momidx}_menu})";
    $err=_docode($gl,$level,$code);
    $code='';
    my $errname="${momname}_$momidx/${momname}_${momidx}_menu";
    if($err) {
      croak "failed to create menu item $errname\n";
    }
  }
  my $idx=0;
  for(@{$$spec[1]}) {
    _loadmenitm $gl,$_,$level+1,"${momname}_${momidx}_menu",$idx;++$idx;
  }
}

sub _getttl {
  my ($gl,$opt,$inp)=@_;
  $opt='title';
  return ($opt,"\"$inp\"");
}

sub _getcmd {
  my ($gl,$opt,$inp)=@_;
  $opt='command';
  my ($cmd,$dummy,$args)=($inp=~/^([^( ]+)\s*([(](.*)[)])?$/);
  my $ocmd='[\&main::'.$cmd.',$gl,'.$args.']';
  return ($opt,$ocmd);
}

sub _getsub {
  my ($gl,$opt,$inp)=@_;
  $opt='command';
  my $ocmd='sub { '.$inp.' }';
  return ($opt,$ocmd);
}

sub _getini {
  my ($gl,$opt,$inp)=@_;
  $$gl{inicode}=$inp;
  return (undef,undef);
}

1;
# The preceding line will make sure the compiler returns a true value

__END__