view release on metacpan or  search on metacpan

Tydra.pl  view on Meta::CPAN

#!/usr/bin/perl -w

use strict;
use Archive::Tyd;
use MIME::Base64 qw(encode_base64);
use Tk;
use Tk::HList;
use Tk::JPEG;
use Tk::PNG;

$SIG{__WARN__} = sub {
};

our $main = MainWindow->new (
	-title => 'Tydra',
);
$main->geometry ('640x480');
$main->optionAdd ('*tearOff', 'false');

our $body = {
	file => undef, # Save file
};

our $tyd = new Archive::Tyd();

#####################
## Menu Bar        ##
#####################

our $menu = $main->Menu (-type => 'menubar');
$main->configure (-menu => $menu);

our $fileMenu = $menu->cascade (
	-label => '~File',
	);

	$fileMenu->command (-label => '~New Archive', -accelerator => 'Ctrl+N', -command => sub {
		&newArchive();
	});

	$fileMenu->command (-label => '~Open Archive', -accelerator => 'Ctrl+O', -command => sub {
		&openArchive();
	});

	$fileMenu->command (-label => '~Save Archive', -accelerator => 'Ctrl+S', -command => sub {
		&saveArchive();
	});

	$fileMenu->command (-label => 'Save Archive ~As...', -accelerator => 'Shift+Ctrl+S', -command => sub {
		&saveArchive('as');
	});

	$fileMenu->command (-label => '~Close Archive', -accelerator => 'Ctrl+W', -command => sub {
		&newArchive();
	});

	$fileMenu->separator;

	$fileMenu->command (-label => '~Exit Tydra', -accelerator => 'Alt+F4', -command => sub {
		exit(0);
	});

our $tydMenu = $menu->cascade (
	-label => '~Tyd',
	);

	$tydMenu->command (-label => '~Add File...', -accelerator => 'Ctrl+A', -command => sub {
		&addFile();
	});

	$tydMenu->command (-label => '~Extract File...', -accelerator => 'Ctrl+E', -command => sub {
		&extractFile();
	});

	$tydMenu->command (-label => '~Delete File', -accelerator => 'Ctrl+X', -command => sub {
		&delFile();
	});

	$tydMenu->command (-label => '~View File', -accelerator => 'Enter', -command => sub {
		&viewFile();
	});

our $helpMenu = $menu->cascade (
	-label => '~Help',
	);

	$helpMenu->command (-label => '~About...', -accelerator => 'F1', -command => sub {
		&about();
	});

#####################
## Binding Keys    ##
#####################

$main->bind ('<Control-n>', \&newArchive);
$main->bind ('<Control-o>', \&openArchive);
$main->bind ('<Control-s>', \&saveArchive);
$main->bind ('<Control-S>', sub { &saveArchive('as'); });
$main->bind ('<Control-w>', \&newArchive);
$main->bind ('<Control-a>', \&addFile);
$main->bind ('<Control-e>', \&extractFile);
$main->bind ('<Control-x>', \&delFile);
$main->bind ('<Return>', \&viewFile);
$main->bind ('<F1>', \&about);

#####################
## Workspace       ##
#####################

our $table = $main->Scrolled ('HList',
	-scrollbars => 'ose',
	-header     => 1,
	-columns    => 2,
	-foreground => '#000000',
	-background => '#FFFFFF',
	-selectforeground => '#000000',
	-selectbackground => '#FFFF00',
	-selectborder     => 0,
	-command    => sub {
		&viewFile();
	},
)->pack (-fill => 'both', -expand => 1);

$table->header ('create', 0, -text => 'File Name');
$table->header ('create', 1, -text => 'Size');

MainLoop;

sub newArchive {
	$tyd = undef;
	$tyd = new Archive::Tyd();

	&refresh();
}

sub openArchive {
	my $file = $main->getOpenFile (
		-defaultextension => 'tyd',
		-filetypes => [
			[ 'Tyd Archive', ['*.tyd', '*.dat'] ],
			[ 'All Files',    '*.*'             ],
		],
		-initialdir => '.',