view release on metacpan or  search on metacpan

vptk_w/Project/Options.pm  view on Meta::CPAN

package vptk_w::Project::Options;

use strict;
use base qw(vptk_w::Project);

sub new {
  my $class = shift;
  my $this  = vptk_w::Project->new(@_);
  foreach($^X, '/usr/local/bin/perl', '/usr/bin/perl') {
    if(-f $_) {
      s/\.exe$//;
      $this->push('perl executable'=>$_);
      last;
    }
  }
#  $this->push('description'=>"This is automatic code generated by $0");
  bless $this => $class;
}

sub print {
  my $this = shift;
  my $parent = shift;
  my @result;
  if ($this->get('fullcode')) {
    push(@result, '#!'.$this->get('perl executable')." -w\n") if $this->get('perl executable');
    push(@result, '# '.$this->get('description')."\n") if $this->get('description');
  }
  push(@result, "use strict;\n") if $this->get('strict');
  if ($this->get('fullcode'))
  {
    # code before tk:
    my $user_code_before_tk = $parent->get('Code')->get('code before tk');
    if(@$user_code_before_tk) {
      push(@result, "#===vptk user code before tk===< THE CODE BELOW WILL RUN BEFORE TK STARTED >===");
      push(@result, @$user_code_before_tk);
    }

    push(@result, "use Tk;") ;
    my %TkTypes;
    foreach my $widget ($parent->get('Widgets')->elements()) {
      next unless exists $widget->{type};
      my $type = &::TkClassName($widget->{type});
      $TkTypes{$type} = 1 if $type;
    }
    push(@result, map("use $_;",sort keys %TkTypes) );
  }
  push(@result, "" );

  return @result;
}

1;#)