view release on metacpan or  search on metacpan

script/tkpp  view on Meta::CPAN

#===============================================================================
# GUI Interface
#===============================================================================
my ( $output_command_widget, $output_stderr_widget, $command, $add_files_rep_listbox ) = ();

my $main = MainWindow->new( -title => $general_configuration{tk}{title} );
$main->withdraw();

# SplashScreen
my $splashscreen_widget = splashscreen_widget($main);

# Configuration option load/save
my $ref_options_pp = {};
my $opt = new Tk::Getopt( -opttable => \@pp_default_options, -options => $ref_options_pp, );
$opt->set_defaults;

#=======
# Menu
#=======
my $bar_menu = $main->Menu( -type => 'menubar', );
$main->configure( -menu => $bar_menu, );

# File Menu
my $file_menu = $bar_menu->cascade( -label => 'File', -tearoff => 0, );
$file_menu->command(
	-label   => '~Load configuration',
	-command => [ \&load_pp_configuration, $main, $opt, $ref_options_pp ],
);
$file_menu->command(
	-label   => '~Save configuration',
	-command => [ \&save_pp_configuration, $main, $opt, $ref_options_pp ],
);
$file_menu->separator;
$file_menu->command(
	-label   => 'Save ~command line',
	-command => sub {
		if ( my $file = save_file( $main, [ 'Batch Files', ['.bat'] ], $general_configuration{commandline_path} ) ) {
			open my $fh, '>', $file or die "Unable to write in $file\n";
			print {$fh} $output_command_widget->get( '1.0', 'end' );
			close $fh or die "Unable to close $file\n";
		}
	}
);
$file_menu->separator;
$file_menu->command( -label => '~Exit', -command => \&close_application, );

# Help Menu
my $help_menu = $bar_menu->cascade( -label => 'Help', -tearoff => 0, );
my $tkpp_pod_menu = $help_menu->command(
	-label   => '~Tkpp documentation',
	-command => [ \&open_pod_documentation, $main, 'tkpp' ],
);
my $pp_pod_menu = $help_menu->command(
	-label   => '~pp documentation',
	-command => [ \&open_pod_documentation, $main, 'pp' ],
);
$help_menu->separator;
$help_menu->command(
	-label   => 'About Tkpp',
	-command => sub { popup_information( $main, $general_configuration{tk}{about_message} ); },
);

$help_menu->command(
	-label   => 'About pp',
	-command => sub { popup_information( $main, $general_configuration{pp_version} ); },
);

#=======
# Header Frame
#=======
my $header_frame = $main->Frame( -background => 'white' );
$header_frame->Label(
	-text       => $general_configuration{tk}{name_application} . ' (v' . $VERSION . ')',
	-background => 'white',
	-font       => '{Arial} 10 {bold}',
)->pack(qw/ -side left -pady 10 -padx 20/);
$header_frame->Label(
	-text       => $general_configuration{tk}{header_title},
	-background => 'white',
	-font       => '{Arial} 12',
)->pack(qw/ -side left/);
$header_frame->Label(
	-image      => get_image_object( $header_frame, par_image(), 'gif' ),
	-background => 'white',
)->pack(qw/ -side right -padx 20 /);

#=======
# Notebook Frame
#=======
my $notebook = $main->NoteBook( -font => '{Arial} 10 bold', -backpagecolor => 'white', );
my $general_notebook = $notebook->add( 'General', -label => 'General Options' );

# DEPRECATED
#my $info_notebook    = $notebook->add( 'Information', -label => 'Information' );

my $size_notebook   = $notebook->add( 'Size',   -label => 'Size' );
my $option_notebook = $notebook->add( 'Option', -label => 'Other Options' );
my $output_notebook = $notebook->add( 'Output', -label => 'Output' );

display_general_notebook();

# DEPRECATED
#display_info_notebook();
display_size_notebook();
display_other_options_notebook();
display_output_notebook();

#=======
# Status Frame
#=======
my $status_frame = $main->Frame( -relief => 'groove', );
$status_frame->Label(
	-textvariable => \$status,
	-font         => '{Arial} 8 {bold}',
)->pack(qw/ -side left -pady 5 -padx 20/);
my $build_button = $status_frame->ColoredButton(
	-text    => 'Build',
	-autofit => 1,
	-font    => '{Arial} 12 bold',
	-tooltip => 'Start building',
	-command => [ \&build_pp, $main, \%options_pp ],
)->pack(qw/-side right -padx 5/);
my $display_commandline_button = $status_frame->ColoredButton(
	-text    => 'Display command line',
	-autofit => 1,

script/tkpp  view on Meta::CPAN

	if ( $nbr_file > 0 ) {
		$current_dir = $files[0];
		open my $fh_write, '>', $last_filedir or die "Unable to write $last_filedir\n";
		print {$fh_write} $current_dir;
		close $fh_write or die "Unable to colse $last_filedir\n";
	}

	return ( $nbr_file == 1 ) ? File::Spec->catfile( $files[0] ) : undef;
}

sub get_label_widget {
	my ( $widget, $ref_info ) = @_;

	my $label = $widget->Label(
		-text    => $ref_info->{text},
		-font    => '{Arial} 10',
		-justify => 'left',
	);
	return $label;
}

sub get_entry_widget {
	my ( $widget, $ref_info ) = @_;

	my $entry = $widget->Entry(
		-textvariable => $ref_info->{textvariable},
		-background   => 'white',
	);
	return $entry;
}

sub get_button_widget {
	my ( $widget, $ref_info ) = @_;

	my $button = $widget->ColoredButton(
		-text    => $ref_info->{text},
		-autofit => 1,
		-font    => '{Arial} 8 bold',
		-tooltip => $ref_info->{tooltip},
		-command => $ref_info->{command},
	);
	return $button;
}

sub get_checkbutton_widget {
	my ( $widget, $ref_info ) = @_;

	my $button = $widget->Checkbutton( -variable => $ref_info->{variable}, );
	return $button;
}

sub build_pp {
	my ( $widget, $ref_options, $display_commandline ) = @_;

	clean_report();
	$command = $EMPTY;

	# perl.exe not found
	if ( !-e $ref_options->{'--perlfile'}{-value} ) {
		my $error = 'The path to ' . basename($EXECUTABLE_NAME) . ' has not been set or invalid.';
		popup_information_warning( $widget, $error );
		$options_pp{'--perlfile'}{-widget}->focus;
		$notebook->raise('General');
		print_error($error);
		return;
	}

	# pp not found
	if ( !-e $ref_options->{'--ppfile'}{-value} ) {
		my $error = 'The path to ' . basename( $general_configuration{pp_path} ) . ' has not been set or invalid.';
		popup_information_warning( $widget, $error );
		$options_pp{'--ppfile'}{-widget}->focus;
		$notebook->raise('General');
		print_error($error);
		return;
	}
	$command .= ' "' . $ref_options->{'--ppfile'}{-value} . $DOUBLE_QUOTE;

	# output not found
	my $output = $ref_options->{'--output'}{-value};
	if ( $output eq $EMPTY ) {
		my $error = 'You must specify an output file to write.';
		popup_information_warning( $widget, $error );
		$options_pp{'--output'}{-widget}->focus;
		$notebook->raise('General');
		print_error($error);
		return;
	}

	# Overwrite output or not
	if ( -e $output ) {
		my $warning = 'The output ' . basename($output) . ' already exists.' . "\n" . 'Do you want overwrite it ?';
		if ( !popup_confirmation( $widget, $warning ) ) {
			$options_pp{'--output'}{-widget}->focus;
			$notebook->raise('General');
			return;
		}

		unlink $output or print_ok("Unable to delete $output"), return;
		print_ok("$output deleted");
	}
	$command .= ' --output="' . $ref_options->{'--output'}{-value} . $DOUBLE_QUOTE;
	print_ok( 'Start building ' . basename($output) );

	# PAR, perlscript check extension
	if ( $ref_options->{'--output'}{-value} =~ m{\.par$}msxi ) {
		$command .= ' --par';
	}
	elsif ( $ref_options->{'--output'}{-value} =~ m{\.pl$}msxi ) {
		$command .= ' --perlscript';
	}
	elsif ( $ref_options->{'--output'}{-value} !~ m{\Q$Config{_exe}\E$}msxi ) {
		my $error = 'You are trying to write your output file as an invalid file format.'
		  . "It must be either a $Config{_exe} or .par file.";
		popup_information_warning( $widget, $error );
		$options_pp{'--output'}{-widget}->focus;
		$notebook->raise('General');
		print_error($error);
		return;
	}

	# Check iconfile
	# if ( my $icon = $ref_options->{'--icon'}{-value} ) {
	#   my $error
	#     = ( !-e $ref_options->{'--icon'}{-value} ) ? 'You have to set an existing icon file'
	#     : ( $icon !~ m{\.(?:dll|ico|exe)$}msxi ) ? 'You are trying to use an icon with bad extension ('
	#     . basename($icon) . ').'
	#     . "\nExtension must be .dll, .exe or .ico."
	#     : undef;
	#
	#   if ( defined $error ) {
	#     popup_information_warning( $widget, $error );
	#     $options_pp{'--icon'}{-widget}->focus;
	#     $notebook->raise('General');
	#     print_error($error);
	#     return;
	#   }
	#   else {
	#     $command .= ' --icon="' . $ref_options->{'--icon'}{-value} . $DOUBLE_QUOTE;
	#   }
	# }

	# GUI
	if ( $ref_options->{'--gui'}{-value} == 1 ) { $command .= ' --gui'; }

	# Log
	if ( my $logfile = $ref_options->{'--log'}{-value} ) {
		$command .= " --log=\"$logfile\"";
		if ( -e $logfile ) { unlink $logfile or die "Unable to delete $logfile\n"; }
	}

	# verbose
	if ( $ref_options->{'--verbose'}{-value} ne 'none' ) {

		# Need to select logfile
		unless ( my $logfile = $ref_options->{'--log'}{-value} ) {
			my $error = 'You have to select a log file if you want to see verbose message.';
			popup_information_warning( $widget, $error );
			$options_pp{'--log'}{-widget}->focus;
			$notebook->raise('General');
			print_error($error);
			return;
		}

		$command .= ' --verbose=' . $ref_options->{'--verbose'}{-value};
	}

	# scandependencies
	if ( $options_pp{'--scandependencies'}{-value} ) {
		$command .= $SPACE . $options_pp{'--scandependencies'}{-value};
	}

	# Log
	if ( my $cachedeps_file = $ref_options->{'--cachedeps'}{-value} ) {
		$command .= " --cachedeps=\"$cachedeps_file\"";
	}

	# Product Informations
	# DEPRECATED
	#foreach my $type ( sort keys %{ $options_pp{'--information'} } ) {
	#  foreach my $key ( sort keys %{ $options_pp{'--information'}{$type} } ) {
	#    if ( my $value = $options_pp{'--information'}{$type}{$key}{-value} ) {
	#      $value =~ s{$DOUBLE_QUOTE}{}g;
	#      $command .= $SPACE . "--info $key=$DOUBLE_QUOTE$value$DOUBLE_QUOTE";
	#    }
	#  }
	#}

	# Exclude Perl
	if ( $options_pp{'--dependent'}{-value} == 1 ) {
		$command .= ' --dependent';
	}

	# Compression
	$command .= ' --compress ' . $options_pp{'--compress'}{-value};

	# Add modules
	if ( my $widget_modules = $options_pp{'--module'}{-widget} ) {
		my $modules = $widget_modules->get || $EMPTY;
		foreach my $module ( split( /;/, $modules ) ) {
			$command .= ' --module="' . $module . $DOUBLE_QUOTE;
		}
	}

	# Exclude modules
	if ( my $widget_modules = $options_pp{'--exclude'}{-widget} ) {
		my $modules = $widget_modules->get || $EMPTY;
		foreach my $module ( split( /;/, $modules ) ) {
			$command .= ' --exclude="' . $module . $DOUBLE_QUOTE;
		}
	}

	# Add files, dir and shared libraries
	foreach my $file_rep ( $add_files_rep_listbox->get( '0', 'end' ) ) {
		chomp $file_rep;
		my ( $type, $file_and_rep ) = $file_rep =~ m{^(f|d|l|s|p):\s*(.+)}msx;
		if ( defined $type ) {
			$command .=
			    ( $type eq 'f' or $type eq 'd' ) ? ' --addfile="' . $file_and_rep . $DOUBLE_QUOTE
			  : ( $type eq 'l' ) ? ' --link="' . $file_and_rep . $DOUBLE_QUOTE
			  : ( $type eq 's' ) ? ' --addlist="' . $file_and_rep . $DOUBLE_QUOTE
			  :                    ' --lib="' . $file_and_rep . $DOUBLE_QUOTE;
		}
	}

	# Other options
	my @yes_not_options =
	  ( '--bundle', '--clean', '--run', '--reusable', '--save', '--sign', '--tempcache', '--multiarch' );
	foreach my $option (@yes_not_options) {
		if ( $options_pp{$option}{-value} == 1 ) {
			$command .= $SPACE . $option;
		}
	}

	# PodStrip
	if ( $options_pp{'--podstrip'}{-value} == 1 ) {
		$ENV{PAR_VERBATIM} = 1;
	}

	# --filter
	if ( my $filter = $options_pp{'--filter'}{-value} and $options_pp{'--filter'}{-value} ne 'None' ) {
		if ( exists $FILTERS_MODULES{$filter} ) {
			eval "use $FILTERS_MODULES{$filter}";
			if ( $EVAL_ERROR !~ /^\s*$/msx ) {
				my $error = "You have to install $FILTERS_MODULES{$filter} to use '$filter' filter";
				popup_information_warning( $widget, $error );
				$options_pp{'--filter'}{-widget}->focus;
				$notebook->raise('Option');
				print_error($error);
				return;
			}
		}
		$command .= ' --filter="' . $filter . $DOUBLE_QUOTE;
	}

	# --modfilter
	if ( my $modfilter = $options_pp{'--modfilter'}{-value} ) {
		foreach my $filter ( split( /;/, $modfilter ) ) {
			$command .= ' --modfilter="' . $filter . $DOUBLE_QUOTE;
		}
	}

	# --eval
	if ( $options_pp{'--eval'}{-value} ) {
		$command .= ' --eval="' . $options_pp{'--eval'}{-value} . $DOUBLE_QUOTE;
	}

	# --evalfeature
	elsif ( $options_pp{'--evalfeature'}{-value} ) {
		$command .= ' --evalfeature="' . $options_pp{'--evalfeature'}{-value} . $DOUBLE_QUOTE;
	}
	elsif ( -e $options_pp{'--sourcefile'}{-value} ) {

		# add source file in command
		$command .= ' "' . $ref_options->{'--sourcefile'}{-value} . $DOUBLE_QUOTE;
	}

	# sourcefile not found
	elsif ( !-e $ref_options->{'--sourcefile'}{-value} ) {
		my $error = 'You must specify a source file to build.';
		popup_information_warning( $widget, $error );
		$options_pp{'--sourcefile'}{-widget}->focus;
		$notebook->raise('General');
		print_error($error);
		return;
	}

	# tkpp is execute in temp directory (read/write). if -M is used, tkpp have to check the module
	# in current source file directory. We will add it in the @INC
	# Perl will execute with -I option to change @INC
	$command = ' -I ' . dirname( $ref_options->{'--sourcefile'}{-value} ) . $command;

	# Display and execute command
	display_command("$EXECUTABLE_NAME $command");

	# Dispay output notebook
	$notebook->raise('Output');

	# Just display command line
	if ( defined $display_commandline ) {
		return;
	}
	execute_command( $EXECUTABLE_NAME, $command, $ref_options->{'--output'}{-value} );

	return;
}

sub execute_command {
	my ( $executable, $arguments, $outputfile_exe ) = @_;

	# Now, we can complet the command line
	$status = $ALL_STATUS{building};

	# Use Win32 Process
	if ( $OSNAME eq 'MSWin32' ) {
		require Win32::Process;
		require Win32;
		import Win32::Process qw(CREATE_NO_WINDOW STILL_ACTIVE );

		my $logfile         = $options_pp{'--log'}{-value};
		my $octet_size_read = 0;
		my $flags           = CREATE_NO_WINDOW();

		Win32::Process::Create( $win32_process_buiding, $executable, $arguments, 0, $flags, '.' )
		  or print_error( 'Erreur [' . Win32::GetLastError() . '] : ' . Win32::FormatMessage( Win32::GetLastError() ) );

		$build_button->configure( -state => 'disabled' );
		$build_button->redraw_button;

		# Check process id running and enabled Build button
		$main->after( $REPEAT_FILE_TIME, [ \&check_process_id, $logfile, \$octet_size_read, $outputfile_exe ] );

	}
	else {
		$main->Busy( -recurse => 1 );
		system( $executable, $arguments ) == 0 or print_error("Command line failed : $?");
		$main->Unbusy();
		$status = $ALL_STATUS{finished};
	}

	return;
}

#================================================
# check process working
#================================================
sub check_process_id {
	my ( $logfile, $ref_octet_size_read, $outputfile_exe ) = @_;
	my $pid = $win32_process_buiding->GetProcessID();
	my $exitcode;
	my $still_active = $win32_process_buiding->GetExitCode($exitcode);

	# Read file
	if ( defined $logfile and -e $logfile ) {
		my ( $buffer, $buffer_size ) = ( undef, 1000 );
		open my $fh, '<', $logfile or die "Unable to read $logfile";
		seek $fh, ${$ref_octet_size_read}, 0;

		while ( read( $fh, $buffer, $buffer_size ) != 0 ) {
			print_ok( $buffer, 1 );
			${$ref_octet_size_read} += $buffer_size;
		}
		close $fh or die "Unable to close $logfile\n";

		#${$ref_octet_size_read} = ( stat($log_file) )[7];
	}

	# Check if process is active
	if ( $exitcode == STILL_ACTIVE() ) {
		$main->after( $REPEAT_FILE_TIME, [ \&check_process_id, $logfile, $ref_octet_size_read, $outputfile_exe ] );
		return;
	}

	$build_button->configure( -state => 'normal' );
	$build_button->redraw_button;
	$win32_process_buiding = undef;

	if ( -e $outputfile_exe ) {
		$status = $ALL_STATUS{finished};
		print_ok("\n ==> $status");
	}
	else {
		$status = $ALL_STATUS{error};
		my $error = Win32::GetLastError();
		print_error("Building $outputfile_exe failed :");
		print_error( Win32::FormatMessage($error) );
		print_error("Active verbose to see more details (General Options)");
		print_ok("\n ==> $status");
	}

	return;
}

#================================================
# popup_information_warning($widget, $message);
#================================================
sub popup_information_warning {
	my ( $widget, $message ) = @_;
	$widget->bell;
	$widget->messageBox(
		-icon    => 'warning',
		-title   => 'Warning',
		-type    => 'OK',
		-message => $message,
	);

	return;
}

#================================================
# popup_information($widget, $message);
#================================================
sub popup_information {
	my ( $widget, $message ) = @_;

	$widget->bell;
	$widget->messageBox(
		-icon    => 'info',
		-title   => 'Information',
		-type    => 'OK',
		-message => $message,
	);

	return;
}

#================================================
# popup_confirmation($widget, $message);
#================================================
sub popup_confirmation {
	my ( $widget, $message ) = @_;

	$widget->bell;
	my $response = $widget->messageBox(
		-icon    => 'info',
		-title   => 'Information',
		-type    => 'OKCANCEL',
		-message => $message,
	);

	$response = uc $response;
	return ( $response eq 'OK' ) ? 1 : undef;
}

#================================================
# Center a widget
#================================================
sub center_widget {
	my ($widget) = @_;

	# Height and width of the screen
	my $width_screen  = $widget->screenwidth();
	my $height_screen = $widget->screenheight();

	# update le widget pour récupérer les vraies dimensions
	$widget->update;
	my $width_widget  = $widget->width;
	my $height_widget = $widget->height;

	# On centre le widget en fonction de la taille de l'écran
	my $new_width  = int( ( $width_screen - $width_widget ) / 2 );
	my $new_height = int( ( $height_screen - $height_widget ) / 2 );
	$widget->geometry( $width_widget . 'x' . $height_widget . "+$new_width+$new_height" );

	$widget->update;

	return;
}

#================================================
# Close Tkpp application
#================================================
sub close_application {

	if ( ( $OSNAME eq 'MSWin32' ) and ( defined $win32_process_buiding ) ) {
		$win32_process_buiding->Kill(0);
	}
	close STDOUT or die "Unable to close STDOUT\n";
	close STDERR or die "Unable to close STDERR\n";

	# Allow to delete temp directory
	chdir $homedir;
	exit;
}

sub open_pod_documentation {
	my ( $widget, $module ) = @_;

	eval { my $pod_widget = $widget->Pod( -file => $module, )->pack(qw/ -fill both -expand 1 /); };