This widget simulates a Macintosh file copy dialog. It uses a CollapsableFrame widget to hide copy details, and a MacProgressBar widget to indicate progress of the copy. See Figure C-2.
Here's the code:
$Tk::MacCopy::VERSION = '1.0';
package Tk::MacCopy;
use File::Copy;
use Tk::widgets qw/CollapsableFrame LabEntry MacProgressBar/;
use base qw/Tk::Toplevel/;
use strict;
Construct Tk::Widget 'MacCopy';
sub Populate {
# Create an instance of a MacCopy widget. Instance variables are:
#
# {bytes_msg} = a string showing how many bytes copied,
# as well as the total byte count.
# {file} = current file being copied.
# {file_count} = number of files left to copy.
# {from} = source directory path.
# {to} = destination directory path.
my($self, $args) = @_;
$self->withdraw;
$self->SUPER::Populate($args);
$args->{-width} = 300 unless exists $args->{-width};
my $pb = $self->MacProgressBar(%$args)->pack;
# Populate the top Frame of the MacProgessBar.
my $tf = $pb->Subwidget('tframe');
$tf->Label(-text => 'Items remaining to be copied: ')->
pack(qw/-side left -anchor w/);
$tf->Label(-textvariable => \$self->{file_count})->
pack(qw/-side right -anchor e/);
# Populate the right Frame of the MacProgessBar.
my $rf = $pb->Subwidget('rframe');
$rf->Button(-text => 'Stop', -command => sub {$self->destroy})->pack;
# Populate the bottom Frame of the MacProgessBar with a CollapsableFrame.
my $bf = $pb->Subwidget('bframe');
my $cf = $bf->CollapsableFrame(-height => 110);
$cf->pack(qw/-fill x -expand 1/);
my $cf_frame = $cf->Subwidget('colf');
# Populate the CollapsableFrame with detail information.
foreach my $item (
['Copying', \$self->{file}],
['From', \$self->{from}],
['To', \$self->{to}],
['Bytes Copied', \$self->{bytes_msg}],
) {
my $l = $item->[0] . ':';
my $le = $cf_frame->LabEntry(
-label => ' ' x (13 - length $l) . $l,
-labelPack => [qw/-side left -anchor w/],
-labelFont => '9x15bold',
-relief => 'flat',
-state => 'disabled',
-textvariable => $item->[1],
-width => 35,
);
$le->pack(qw/ -fill x -expand 1/);
}
$self->Advertise('collapsableframe' => $cf);
$self->Advertise('progressbar' => $pb);
} # end Populate
sub mcopy {
# Perform the copy, updating copy information on-the-fly. Because
# this is just a demo, we don't recursively copy subdirectories.
my($self, $from, $to) = @_;
$self->{from} = $from;
$self->{to} = $to;
$self->deiconify;
opendir D, $from;
my(@files) = grep(! -d $_, readdir D);
closedir D;
my $total_bytes = 0;
foreach my $f (@files) {
$total_bytes += -s $f;
}
$self->{file_count} = scalar @files;
$self->update;
my $filen = 0;
my $bytes = 0;
foreach my $f (@files) {
$filen++;
$self->{file} = $f;
my $size = -s $f;
my $stat = copy($f, "$to/$f");
$self->messageBox(
-title => 'MacCopy Failure',
-icon => 'warning',
-type => 'OK',
-message => "Copy of '$f' failed: $!",
) unless $stat;
$bytes += $size;
$self->{bytes_msg} = $bytes . " of $total_bytes";
$self->{file_count}--;
$self->Subwidget('collapsableframe')->configure(-text =>
"Time Remaining: About " . $self->{file_count} . " seconds");
$self->Subwidget('progressbar')->set($filen / scalar(@files) * 100);
$self->after(1000);
}
$self->destroy;
} # end mcopy
1;
__END__
=head1 NAME
Tk::MacCopy - simulate a Macintosh copy dialog.
=head1 SYNOPSIS
S< >I<$cd> = I<$parent>-E<gt>B<MacCopy>(I<-option> =E<gt> I<value>);
=head1 DESCRIPTION
This widget simulates a Macintosh copy dialog using a MacProgressBar
and a CollapsableFrame. It does not truly emulate a real Macintosh
copy, since it doesn't:
. check that the destination has enough room for the copy.
. recursively copy subdirectories.
. compute a time remaining figure.
=head1 METHODS
=over 4
=item B<mcopy($to, $from)>
Copies all files from $to directory to $from directory.
=back
=head1 ADVERTISED WIDGETS
Component subwidgets can be accessed via the B<Subwidget> method.
Valid subwidget names are listed below.
=over 4
=item Name: progressbar, Class: MacProgressBar
MacProgressBar widget reference.
=item Name: collapsableframe, Class: CollapsableFrame
CollapsableFrame widget reference.
=back
=head1 EXAMPLE
use Cwd;
use Tk;
use Tk::MacCopy;
my $mw = MainWindow->new;
my $mc = $mw->MacCopy;
my $cwd = cwd;
$mw->Button(
-text => "Push me to copy all files in '$cwd' to '/tmp'.",
-command => sub {$mc->mcopy($cwd, '/tmp'); exit},
)->pack;
=head1 AUTHOR and COPYRIGHT
[email protected]
Copyright (C) 2000 - 2001, Stephen O.Lidie
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 KEYWORDS
CollapsableFrame, MacCopy, MacProgressBar
=cut
Copyright © 2002 O'Reilly & Associates. All rights reserved.