sorune-0.5/0040755000076400001440000000000010176566277012303 5ustar nerevaruserssorune-0.5/bin/0040755000076400001440000000000010176566323013043 5ustar nerevaruserssorune-0.5/bin/wavread.pm0100644000076400001440000004026110175600016015015 0ustar nerevaruserspackage Audio::Wav::Read; use strict; use FileHandle; use vars qw( $VERSION ); $VERSION = '0.04'; =head1 NAME Audio::Wav::Read - Module for reading Microsoft WAV files. =head1 SYNOPSIS use Audio::Wav; my $wav = new Audio::Wav; my $read = $wav -> read( 'filename.wav' ); my $details = $read -> details(); =head1 DESCRIPTION Reads Microsoft Wav files. =head1 SEE ALSO L L =head1 NOTES This module shouldn't be used directly, a blessed object can be returned from L. =head1 METHODS =cut sub new { my $class = shift; my $file = shift; my $tools = shift; $file =~ s#//#/#g; my $size = -s $file; my $handle = new FileHandle "<$file"; my $self = { 'real_size' => $size, 'file' => $file, 'handle' => $handle, 'tools' => $tools, }; bless $self, $class; unless ( defined $handle ) { $self -> _error( "unable to open file ($!)" ); return $self; } binmode $handle; $self -> {'data'} = $self -> _read_file(); my $details = $self -> details(); $self -> _init_read_sub(); $self -> {'pos'} = $details -> {'data_start'}; $self -> move_to(); return $self; } =head2 file_name Returns the file name. my $file = $read -> file_name(); =cut sub file_name { my $self = shift; return $self -> {'file'}; } =head2 get_info Returns information contained within the wav file. my $info = $read -> get_info(); Returns a reference to a hash containing; (for example, a file marked up for use in Audio::Mix) { 'keywords' => 'bpm:126 key:a', 'name' => 'Mission Venice', 'artist' => 'Nightmares on Wax' }; =cut sub get_info { my $self = shift; return undef unless exists( $self -> {'data'} -> {'info'} ); return $self -> {'data'} -> {'info'}; } =head2 get_cues Returns the cuepoints marked within the wav file. my $cues = $read -> get_cues(); Returns a reference to a hash containing; (for example, a file marked up for use in Audio::Mix) (position is sample position) { 1 => { label => 'sig', position => 764343, note => 'first' }, 2 => { label => 'fade_in', position => 1661774, note => 'trig' }, 3 => { label => 'sig', position => 18033735, note => 'last' }, 4 => { label => 'fade_out', position => 17145150, note => 'trig' }, 5 => { label => 'end', position => 18271676 } } =cut sub get_cues { my $self = shift; return undef unless exists( $self -> {'data'} -> {'cue'} ); my $data = $self -> {'data'}; my $cues = $data -> {'cue'}; my $output = {}; foreach my $id ( keys %$cues ) { my $pos = $cues -> {$id} -> {'position'}; my $record = { 'position' => $pos }; $record -> {'label'} = $data -> {'labl'} -> {$id} if ( exists $data -> {'labl'} -> {$id} ); $record -> {'note'} = $data -> {'note'} -> {$id} if ( exists $data -> {'note'} -> {$id} ); $output -> {$id} = $record; } return $output; } =head2 read_raw Reads raw packed bytes from the current audio data position in the file. my $data = $self -> read_raw( $byte_length ); =cut sub read_raw { my $self = shift; my $len = shift; my $data_finish = $self -> {'data'} -> {'data_finish'}; if ( $self -> {'pos'} + $len > $data_finish ) { $len = $data_finish - $self -> {'pos'}; } return $self -> _read_raw( $len ); } =head2 read_raw_samples Reads raw packed samples from the current audio data position in the file. my $data = $self -> read_raw_samples( $samples ); =cut sub read_raw_samples { my $self = shift; my $len = shift; $len *= $self -> {'data'} -> {'block_align'}; return $self -> read_raw( $len ); } sub _read_raw { my $self = shift; my $len = shift; my $data; return undef unless $len && $len > 0; $self -> {'pos'} += read( $self -> {'handle'}, $data, $len ); return $data; } =head2 read Returns the current audio data position sample across all channels. my @channels = $self -> read(); Returns an array of unpacked samples. Each element is a channel i.e ( left, right ). The numbers will be in the range; where $samp_max = ( 2 ** bits_per_sample ) / 2 -$samp_max to +$samp_max =cut sub read { my $self = shift; my $val; my $block = $self -> {'data'} -> {'block_align'}; return () if $self -> {'pos'} + $block > $self -> {'data'} -> {'data_finish'}; $self -> {'pos'} += read( $self -> {'handle'}, $val, $block ); return () unless defined( $val ); return &{ $self -> {'read_sub'} }( $val ); } sub _init_read_sub { my $self = shift; my $details = $self -> {'data'}; my $channels = $details -> {'channels'}; my $sub; # Darren Smith, added to suppress warning if (!defined $details->{'bits_sample'}) { return; } if ( $details -> {'bits_sample'} <= 8 ) { my $offset = ( 2 ** $details -> {'bits_sample'} ) / 2; $sub = sub { return map $_ - $offset, unpack( 'C'.$channels, shift() ) }; } else { if ( $self -> {'tools'} -> is_big_endian() ) { $sub = sub { return unpack( 's' . $channels, # 3. unpack native as signed short pack( 'S' . $channels, # 2. pack native unsigned short unpack( 'v' . $channels, shift() ) # 1. unpack little-endian unsigned short ) ); }; } else { $sub = sub { return unpack( 's' . $channels, shift() ) }; } } $self -> {'read_sub'} = $sub; } =head2 position Returns the current audio data position (as byte offset). my $byte_offset = $read -> position(); =cut sub position { my $self = shift; return $self -> {'pos'} - $self -> {'data'} -> {'data_start'}; } =head2 position_samples Returns the current audio data position (in samples). my $samples = $read -> position_samples(); =cut sub position_samples { my $self = shift; return ( $self -> {'pos'} - $self -> {'data'} -> {'data_start'} ) * $self -> {'data'} -> {'block_align'}; } =head2 move_to Moves the current audio data position to byte offset. $read -> move_to( $byte_offset ); =cut sub move_to { my $self = shift; my $pos = shift; my $data_start = $self -> {'data'} -> {'data_start'}; # Darren Smith, added to suppress warning if ( defined $pos ) { $pos = 0 if $pos < 0; } else { $pos = 0; } $pos += $data_start; if ( $pos > $self -> {'pos'} ) { my $max_pos = $self -> reread_length() + $data_start; $pos = $max_pos if $pos > $max_pos; } if ( seek $self -> {'handle'}, $pos, 0 ) { $self -> {'pos'} = $pos; return 1; } else { return $self -> _error( "can't move to position '$pos'" ); } } =head2 move_to_sample Moves the current audio data position to sample offset. $read -> move_to_sample( $sample_offset ); =cut sub move_to_sample { my $self = shift; my $pos = shift; return $self -> move_to() unless defined( $pos ); return $self -> move_to( $pos * $self -> {'data'} -> {'block_align'} ); } =head2 length Returns the number of bytes of audio data in the file. my $audio_bytes = $read -> length(); =cut sub length { my $self = shift; return $self -> {'data'} -> {'data_length'}; } =head2 length_samples Returns the number of samples of audio data in the file. my $audio_samples = $read -> length_samples(); =cut sub length_samples { my $self = shift; my $data = $self -> {'data'}; # Added check to prevent / by 0 errors (darren smith, 3/27/04) if ($data -> {'block_align'}) { return $data -> {'data_length'} / $data -> {'block_align'}; } else { return 0; } } =head2 length_seconds Returns the number of seconds of audio data in the file. my $audio_seconds = $read -> length_seconds(); =cut sub length_seconds { my $self = shift; my $data = $self -> {'data'}; # Added check to prevent / by 0 errors (darren smith, 3/27/04) if ($data -> {'bytes_sec'}) { return $data -> {'data_length'} / $data -> {'bytes_sec'}; } else { return 0; } } =head2 details Returns a reference to a hash of lots of details about the file. Too many to list here, try it with Data::Dumper..... use Data::Dumper; my $details = $read -> details(); print Data::Dumper->Dump([ $details ]); =cut sub details { my $self = shift; return $self -> {'data'}; } =head2 reread_length Rereads the length of the file in case it is being written to as we are reading it. my $new_data_length = $read -> reread_length(); =cut sub reread_length { my $self = shift; my $handle = $self -> {'handle'}; my $old_pos = $self -> {'pos'}; my $data = $self -> {'data'}; my $data_start = $data -> {'data_start'}; seek $handle, $data_start - 4, 0; my $new_length = $self -> _read_long(); seek $handle, $old_pos, 0; $data -> {'data_length'} = $new_length; return $new_length; } ######### sub _read_file { my $self = shift; my $handle = $self -> {'handle'}; my %details; my $type = $self -> _read_raw( 4 ); my $length = $self -> _read_long( ); my $subtype = $self -> _read_raw( 4 ); my $tools = $self -> {'tools'}; my $old_cooledit = $tools -> is_oldcooledithack(); my $debug = $tools -> is_debug(); $details{'total_length'} = $length; unless ( $type eq 'RIFF' && $subtype eq 'WAVE' ) { return $self -> _error( "doesn't seem to be a wav file" ); } my $walkover; # for fixing cooledit 96 data-chunk bug while ( ! eof $handle && $self -> {'pos'} < $length ) { my $head; if ( $walkover ) { # rectify cooledit 96 data-chunk bug $head = $walkover . $self -> _read_raw( 3 ); $walkover = undef; print( "debug: CoolEdit 96 data-chunk bug detected!\n" ) if $debug; } else { $head = $self -> _read_raw( 4 ); } my $chunk_len = $self -> _read_long(); printf( "debug: head: '$head' at %6d (%6d bytes)\n", $self->{pos}, $chunk_len ) if $debug; if ( $head eq 'fmt ' ) { my $format = $self -> _read_fmt( $chunk_len ); my $comp = delete( $format -> {'format'} ); unless ( $comp == 1 ) { return $self -> _error( "seems to be compressed, I can't handle anything other than uncompressed PCM" ); } %details = ( %details, %$format ); next; } elsif ( $head eq 'cue ' ) { $details{'cue'} = $self -> _read_cue( $chunk_len, \%details ); next; } elsif ( $head eq 'smpl' ) { $details{'sampler'} = $self -> _read_sampler( $chunk_len ); next; } elsif ( $head eq 'LIST' ) { my $list = $self -> _read_list( $chunk_len, \%details ); next; } elsif ( $head eq 'DISP' ) { $details{'display'} = $self -> _read_disp( $chunk_len ); next; } elsif ( $head eq 'data' ) { $details{'data_start'} = $self -> {'pos'}; $details{'data_length'} = $chunk_len; } else { $head =~ s/[^\w]+//g; $self -> _error( "ignored unknown block type: $head at $self->{pos} for $chunk_len", 'warn' ); next if $chunk_len > 100; } seek $handle, $chunk_len, 1; $self -> {'pos'} += $chunk_len; # read padding if ($chunk_len % 2) { my $pad = $self->_read_raw(1); if ( ($pad =~ /\w/) && $old_cooledit && ($head eq 'data') ) { # Oh no, this file was written by cooledit 96... # This is not a pad byte but the first letter of the next head. $walkover = $pad; } } #unless ( $old_cooledit ) { # $chunk_len += 1 if $chunk_len % 2; # padding #} #seek $handle, $chunk_len, 1; #$self -> {'pos'} += $chunk_len; } if ( exists $details{'data_start'} ) { # Added check to prevent / by 0 errors (darren smith, 3/27/04) if ($details{'bytes_sec'}) { $details{'length'} = $details{'data_length'} / $details{'bytes_sec'}; } else { $details{'length'} = 0; } $details{'data_finish'} = $details{'data_start'} + $details{'data_length'}; } else { $details{'data_start'} = 0; $details{'data_length'} = 0; $details{'length'} = 0; $details{'data_finish'} = 0; } return \%details; } sub _read_list { my $self = shift; my $length = shift; my $details = shift; my $note = $self -> _read_raw( 4 ); my $pos = 4; if ( $note eq 'adtl' ) { my %allowed = map { $_, 1 } qw( ltxt note labl ); while ( $pos < $length ) { my $head = $self -> _read_raw( 4 ); $pos += 4; if ( $head eq 'ltxt' ) { my $record = $self -> _decode_block( [ 1 .. 6 ] ); $pos += 24; } else { my $bits = $self -> _read_long(); $pos += $bits + 4; if ( $head eq 'labl' || $head eq 'note' ) { my $id = $self -> _read_long(); my $text = $self -> _read_raw( $bits - 4 ); $text =~ s/\0+$//; $details -> {$head} -> {$id} = $text; } else { my $unknown = $self -> _read_raw ( $bits ); # skip unknown chunk } if ($bits % 2) { # eat padding my $padding = $self -> _read_raw(1); $pos++; } } } # if it's a broken file and we've read too much then go back if ( $pos > $length ) { seek $self->{'handle'}, $length-$pos, 1; } } elsif ( $note eq 'INFO' ) { my %allowed = $self -> {'tools'} -> get_info_fields(); while ( $pos < $length ) { my $head = $self -> _read_raw( 4 ); $pos += 4; my $bits = $self -> _read_long(); $pos += $bits + 4; my $text = $self -> _read_raw( $bits ); if ( $allowed{$head} ) { $text =~ s/\0+$//; $details -> {'info'} -> { $allowed{$head} } = $text; } if ($bits % 2) { # eat padding my $padding = $self -> _read_raw(1); $pos++; } } } else { my $data = $self -> _read_raw( $length - 4 ); } } sub _read_cue { my $self = shift; my $length = shift; my $details = shift; my $cues = $self -> _read_long(); my @fields = qw( id position chunk cstart bstart offset ); my @plain = qw( chunk ); my $output; for ( 1 .. $cues ) { my $record = $self -> _decode_block( \@fields, \@plain ); my $id = delete( $record -> {'id'} ); $output -> {$id} = $record; } return $output; } sub _read_disp { my $self = shift; my $length = shift; my $type = $self -> _read_long(); my $data = $self -> _read_raw( $length - 4 + ($length%2) ); $data =~ s/\0+$//; return [ $type, $data ]; } sub _read_sampler { my $self = shift; my $length = shift; my %sampler_fields = $self -> {'tools'} -> get_sampler_fields(); my $record = $self -> _decode_block( $sampler_fields{'fields'} ); for my $id ( 1 .. $record -> {'sample_loops'} ) { push @{ $record -> {'loop'} }, $self -> _decode_block( $sampler_fields{'loop'} ); } $record -> {'sample_specific_data'} = _read_raw( $record -> {'sample_data'} ); my $read_bytes = 9 * 4 # sampler info + 6 * 4 * $record -> {'sample_loops'} # loops + $record -> {'sample_data'}; # specific data # read any junk if ($read_bytes < $length ) { my $junk = $self->_read_raw( $length - $read_bytes ); } if ( $length % 2 ) { my $pad = $self -> _read_raw( 1 ); } # temporary nasty hack to gooble the last bogus 12 bytes #my $extra = $self -> _decode_block( $sampler_fields{'extra'} ); return $record; } sub _decode_block { my $self = shift; my $fields = shift; my $plain = shift; my %plain; if ( $plain ) { foreach my $field ( @$plain ) { for my $id ( 0 .. $#$fields ) { next unless $fields -> [$id] eq $field; $plain{$id} = 1; } } } my $no_fields = scalar( @$fields ); my %record; for my $id ( 0 .. $#$fields ) { if ( exists $plain{$id} ) { $record{ $fields -> [$id] } = $self -> _read_raw( 4 ); } else { $record{ $fields -> [$id] } = $self -> _read_long(); } } return \%record; } sub _read_fmt { my $self = shift; my $length = shift; my $data = $self -> _read_raw( $length ); my $types = $self -> {'tools'} -> get_wav_pack(); my $pack_str = ''; my $fields = $types -> {'order'}; foreach my $type ( @$fields ) { $pack_str .= $types -> {'types'} -> {$type}; } my @data = unpack( $pack_str, $data ); my %record; for my $id ( 0 .. $#$fields ) { $record{ $fields -> [$id] } = $data[$id]; } return { %record }; } sub _read_long { my $self = shift; my $data = $self -> _read_raw( 4 ); return unpack( 'V', $data ); } sub _error { my $self = shift; return $self -> {'tools'} -> error( $self -> {'file'}, @_ ); } =head1 AUTHORS Nick Peskett (see http://www.peskett.co.uk/ for contact details). Kurt George Gjerde . (from 0.02) =cut 1; sorune-0.5/bin/toolbar.pm0100644000076400001440000007353110175733300015037 0ustar nerevarusers package Tk::ToolBar; use strict; use Tk::Frame; use Tk::Balloon; use File::Basename; use base qw/Tk::Frame/; use Tk::widgets qw(Frame); use Carp; use POSIX qw/ceil/; Construct Tk::Widget 'ToolBar'; use vars qw/$VERSION/; $VERSION = 0.09; my $edgeH = 24; my $edgeW = 5; my $sepH = 24; my $sepW = 3; my %sideToSticky = qw( top n right e left w bottom s ); my $packIn = ''; my @allWidgets = (); my $floating = 0; my %packIn; my %containers; my %isDummy; 1; # Modified to find tkIcons in @INC and changed carp message. (4/18/04, Darren) # Modified to set bg colors. (6/19/04, Darren) sub ClassInit { my ($class, $mw) = @_; $class->SUPER::ClassInit($mw); # my @icons = Sorune::Icons::getSoruneIcons(); # my $dirname = dirname($0); # while (scalar @icons) { # my $n = shift @icons; # my $d = shift @icons; # if (-r "$dirname/$n.png") { # $mw->Photo($n, -file => "$dirname/$n.png"); # } elsif (-r "$dirname/$n.gif") { # $mw->Photo($n, -file => "$dirname/$n.gif"); # } else { # $mw->Photo($n, -data => $d); # } # } } sub Populate { my ($self, $args) = @_; $self->SUPER::Populate($args); $self->{MW} = $self->parent; $self->{SIDE} = exists $args->{-side} ? delete $args->{-side} : 'top'; $self->{STICKY} = exists $args->{-sticky} ? delete $args->{-sticky} : 'nsew'; $self->{USECC} = exists $args->{-cursorcontrol} ? delete $args->{-cursorcontrol} : 1; $self->{STYLE} = exists $args->{-mystyle} ? delete $args->{-mystyle} : 0; $packIn = exists $args->{-in} ? delete $args->{-in} : ''; if ($packIn) { unless ($packIn->isa('Tk::ToolBar')) { croak "value of -packin '$packIn' is not a Tk::ToolBar object"; } else { $self->{SIDE} = $packIn->{SIDE}; } } unless ($self->{STICKY} =~ /$sideToSticky{$self->{SIDE}}/) { croak "can't place '$self->{STICKY}' toolbar on '$self->{SIDE}' side"; } $self->{CONTAINER} = $self->{MW}->Frame; $self->_packSelf; my $edge = $self->{CONTAINER}->Frame(qw/ -borderwidth 2 -relief ridge /); $self->{EDGE} = $edge; $self->_packEdge($edge, 1); $self->ConfigSpecs( -movable => [qw/METHOD movable Movable 1/], -close => [qw/PASSIVE close Close 15/], -activebackground => [qw/METHOD activebackground ActiveBackground/, Tk::ACTIVE_BG], -indicatorcolor => [qw/PASSIVE indicatorcolor IndicatorColor/, '#00C2F1'], -indicatorrelief => [qw/PASSIVE indicatorrelief IndicatorRelief flat/], -float => [qw/PASSIVE float Float 1/], ); push @allWidgets => $self; $containers{$self->{CONTAINER}} = $self; $self->{BALLOON} = $self->{MW}->Balloon; # check for Tk::CursorControl $self->{CC} = undef; if ($self->{USECC}) { local $^W = 0; # suppress message from Win32::API eval "require Tk::CursorControl"; unless ($@) { # CC is installed. Use it. $self->{CC} = $self->{MW}->CursorControl; } } } sub _packSelf { my $self = shift; my $side = $self->{SIDE}; my $fill = 'y'; if ($side eq 'top' or $side eq 'bottom') { $fill = 'x' } if ($packIn && $packIn != $self) { my $side = $packIn->{SIDE} =~ /top|bottom/ ? 'left' : 'top'; $self->{CONTAINER}->pack(-in => $packIn->{CONTAINER}, -side => $side, -anchor => ($fill eq 'x' ? 'w' : 'n'), -expand => 0); $self->{CONTAINER}->raise; $packIn{$self->{CONTAINER}} = $packIn->{CONTAINER}; } else { # force a certain look! for now. my $slave = ($self->{MW}->packSlaves)[0]; $self->configure(qw/-relief raised -borderwidth 1/); $self->pack(-side => $side, -fill => $fill, $slave ? (-before => $slave) : () ); $self->{CONTAINER}->pack(-in => $self, -anchor => ($fill eq 'x' ? 'w' : 'n'), -expand => 0); $packIn{$self->{CONTAINER}} = $self; } } sub _packEdge { my $self = shift; my $e = shift; my $w = shift; my $s = $self->{SIDE}; my ($pack, $pad, $nopad, $fill); if ($s eq 'top' or $s eq 'bottom') { if ($w) { $e->configure(-height => $edgeH, -width => $edgeW); } else { $e->configure(-height => $sepH, -width => $sepW); } $pack = 'left'; $pad = '-padx'; $nopad = '-pady'; $fill = 'y'; } else { if ($w) { $e->configure(-height => $edgeW, -width => $edgeH); } else { $e->configure(-height => $sepW, -width => $sepH); } $pack = 'top'; $pad = '-pady'; $nopad = '-padx'; $fill = 'x'; } if (exists $self->{SEPARATORS}{$e}) { $e->configure(-cursor => $pack eq 'left' ? 'sb_h_double_arrow' : 'sb_v_double_arrow'); $self->{SEPARATORS}{$e}->pack(-side => $pack, -fill => $fill); } $e->pack(-side => $pack, $pad => 5, $nopad => 0, -expand => 0); } sub movable { my ($self, $value) = @_; if (defined $value) { $self->{ISMOVABLE} = $value; my $e = $self->_edge; if ($value) { $e->configure(qw/-cursor fleur/); $self->afterIdle(sub {$self->_enableEdge()}); } else { $e->configure(-cursor => undef); $self->_disableEdge($e); } } return $self->{ISMOVABLE}; } sub _enableEdge { my ($self) = @_; my $e = $self->_edge; my $hilte = $self->{MW}->Frame(-bg => $self->cget('-indicatorcolor'), -relief => $self->cget('-indicatorrelief')); my $dummy = $self->{MW}->Frame( qw/ -borderwidth 2 -relief ridge /); $self->{DUMMY} = $dummy; my $drag = 0; #my $floating = 0; my $clone; my @mwSize; # extent of mainwindow. $e->bind('<1>' => sub { $self->{CC}->confine($self->{MW}) if defined $self->{CC}; my $geom = $self->{MW}->geometry; my ($rx, $ry) = ($self->{MW}->rootx, $self->{MW}->rooty); if ($geom =~ /(\d+)x(\d+)/) {#\+(\d+)\+(\d+)/) { # @mwSize = ($3, $4, $1 + $3, $2 + $4); @mwSize = ($rx, $ry, $1 + $rx, $2 + $ry); } else { @mwSize = (); } if (!$self->{ISCLONE} && $self->{CLONE}) { $self->{CLONE}->destroy; $self->{CLONE} = $clone = undef; @allWidgets = grep Tk::Exists, @allWidgets; } }); $e->bind('' => sub { my ($x, $y) = ($self->pointerx - $self->{MW}->rootx - ceil($e->width /2) - $e->x, $self->pointery - $self->{MW}->rooty - ceil($e->height/2) - $e->y); my ($px, $py) = $self->pointerxy; $dummy = $self->{ISCLONE} ? $self->{CLONE}{DUMMY} : $self->{DUMMY}; unless ($drag or $floating) { $drag = 1; $dummy->raise; my $noclone = $self->{ISCLONE} ? $self->{CLONE} : $self; $noclone->packForget; $noclone->{CONTAINER}->pack(-in => $dummy); $noclone->{CONTAINER}->raise; ref($_) eq 'Tk::Frame' && $_->raise for $noclone->{CONTAINER}->packSlaves; } $hilte->placeForget; if ($self->cget('-float') && (@mwSize and $px < $mwSize[0] or $py < $mwSize[1] or $px > $mwSize[2] or $py > $mwSize[3])) { # we are outside .. switch to toplevel mode. $dummy->placeForget; $floating = 1; unless ($self->{CLONE} || $self->{ISCLONE}) { # clone it. my $clone = $self->{MW}->Toplevel(qw/-relief ridge -borderwidth 2/); $clone->withdraw; $clone->overrideredirect(1); $self->_clone($clone); $self->{CLONE} = $clone; } $clone = $self->{ISCLONE} || $self->{CLONE}; $clone->deiconify unless $clone->ismapped; $clone->geometry("+$px+$py"); } else { $self->{ISCLONE}->withdraw if $self->{CLONE} && $self->{ISCLONE}; $dummy->place('-x' => $x, '-y' => $y); $floating = 0; if (my $newSide = $self->_whereAmI($x, $y)) { # still inside main window. # highlight the close edge. $clone && $clone->ismapped && $clone->withdraw; #$self->{ISCLONE}->withdraw if $self->{CLONE} && $self->{ISCLONE}; my ($op, $pp); if ($newSide =~ /top/) { $op = [qw/-height 5/]; $pp = [qw/-relx 0 -relwidth 1 -y 0/]; } elsif ($newSide =~ /bottom/) { $op = [qw/-height 5/]; $pp = [qw/-relx 0 -relwidth 1 -y -5 -rely 1/]; } elsif ($newSide =~ /left/) { $op = [qw/-width 5/]; $pp = [qw/-x 0 -relheight 1 -y 0/]; } elsif ($newSide =~ /right/) { $op = [qw/-width 5/]; $pp = [qw/-x -5 -relx 1 -relheight 1 -y 0/]; } $hilte->configure(@$op); $hilte->place(@$pp); $hilte->raise; } } }); $e->bind('' => sub { my $noclone = $self->{ISCLONE} ? $self->{CLONE} : $self; $noclone->{CC}->free($noclone->{MW}) if defined $noclone->{CC}; return unless $drag; $drag = 0; $dummy->placeForget; # forget everything if it's cloned. return if $clone && $clone->ismapped; # destroy the clone. #$clone->destroy; #return unless $self->_whereAmI(1); $noclone->_whereAmI(1); $hilte->placeForget; # repack everything now. my $ec = $noclone->_edge; my @allSlaves = grep {$_ ne $ec} $noclone->{CONTAINER}->packSlaves; $_ ->packForget for $noclone, @allSlaves, $noclone->{CONTAINER}; $noclone->_packSelf; $noclone->_packEdge($ec, 1); $noclone->_packWidget($_) for @allSlaves; }); } sub _whereAmI { my $self = shift; my $flag = 0; my ($x, $y); if (@_ == 1) { $flag = shift; my $e = $self->_edge; ($x, $y) = ($self->pointerx - $self->{MW}->rootx - ceil($e->width /2) - $e->x, $self->pointery - $self->{MW}->rooty - ceil($e->height/2) - $e->y); } else { ($x, $y) = @_; } my $x2 = $x + $self->{CONTAINER}->width; my $y2 = $y + $self->{CONTAINER}->height; my $w = $self->{MW}->Width; my $h = $self->{MW}->Height; # bound check $x = 1 if $x <= 0; $y = 1 if $y <= 0; $x = $w - 1 if $x >= $w; $y = $h - 1 if $y >= $h; $x2 = 0 if $x2 <= 0; $y2 = 0 if $y2 <= 0; $x2 = $w - 1 if $x2 >= $w; $y2 = $h - 1 if $y2 >= $h; my $dx = 0; my $dy = 0; my $close = $self->cget('-close'); if ($x < $close) { $dx = $x } elsif ($w - $x2 < $close) { $dx = $x2 - $w } if ($y < $close) { $dy = $y } elsif ($h - $y2 < $close) { $dy = $y2 - $h } $packIn = ''; if ($dx || $dy) { my $newSide; if ($dx && $dy) { # which is closer? if (abs($dx) < abs($dy)) { $newSide = $dx > 0 ? 'left' : 'right'; } else { $newSide = $dy > 0 ? 'top' : 'bottom'; } } elsif ($dx) { $newSide = $dx > 0 ? 'left' : 'right'; } else { $newSide = $dy > 0 ? 'top' : 'bottom'; } # make sure we're stickable on that side. return undef unless $self->{STICKY} =~ /$sideToSticky{$newSide}/; $self->{SIDE} = $newSide if $flag; return $newSide; } elsif ($flag) { # check for overlaps. for my $w (@allWidgets) { next if $w == $self; my $x1 = $w->x; my $y1 = $w->y; my $x2 = $x1 + $w->width; my $y2 = $y1 + $w->height; if ($x > $x1 and $y > $y1 and $x < $x2 and $y < $y2) { $packIn = $w; last; } } $self->{SIDE} = $packIn->{SIDE} if $packIn; # if ($packIn) { # $self->{SIDE} = $packIn->{SIDE}; # } else { # return undef; # } } else { return undef; } return 1; } sub _disableEdge { my ($self, $e) = @_; $e->bind('' => undef); $e->bind('' => undef); } sub _edge { $_[0]->{EDGE}; } sub ToolButton { my $self = shift; my %args = @_; my $type = delete $args{-type} || 'Button'; unless ($type eq 'Button' or $type eq 'Checkbutton' or $type eq 'Menubutton' or $type eq 'Radiobutton') { croak "toolbutton can be only 'Button', 'Menubutton', 'Checkbutton', or 'Radiobutton'"; } my $m = delete $args{-tip} || ''; my $x = delete $args{-accelerator} || ''; my $b = $self->{CONTAINER}->$type(%args, $self->{STYLE} ? () : ( -relief => 'flat', -borderwidth => 1, -highlightthickness => 0, ), ); $self->_createButtonBindings($b); $self->_configureWidget ($b); push @{$self->{WIDGETS}} => $b; $self->_packWidget($b); $self->{BALLOON}->attach($b, -balloonmsg => $m) if $m; $self->{MW}->bind($x => [$b, 'invoke']) if $x; # change the bind tags. #$b->bindtags([$b, ref($b), $b->toplevel, 'all']); return $b; } sub ToolLabel { my $self = shift; my $l = $self->{CONTAINER}->Label(@_); push @{$self->{WIDGETS}} => $l; $self->_packWidget($l); return $l; } sub ToolEntry { my $self = shift; my %args = @_; my $m = delete $args{-tip} || ''; my $l = $self->{CONTAINER}->Entry(%args, -width => 5); push @{$self->{WIDGETS}} => $l; $self->_packWidget($l); $self->{BALLOON}->attach($b, -balloonmsg => $m) if $m; return $l; } sub ToolLabEntry { my $self = shift; my %args = @_; require Tk::LabEntry; my $m = delete $args{-tip} || ''; my $l = $self->{CONTAINER}->LabEntry(%args, -width => 5); push @{$self->{WIDGETS}} => $l; $self->_packWidget($l); $self->{BALLOON}->attach($b, -balloonmsg => $m) if $m; return $l; } sub ToolOptionmenu { my $self = shift; my %args = @_; my $m = delete $args{-tip} || ''; my $l = $self->{CONTAINER}->Optionmenu(%args); push @{$self->{WIDGETS}} => $l; $self->_packWidget($l); $self->{BALLOON}->attach($b, -balloonmsg => $m) if $m; return $l; } sub activebackground { my ($self, $c) = @_; return unless $c; # ignore falses. $self->{ACTIVE_BG} = $c; $self->{CONTAINER}->configure(-background => $c); $self->{EDGE}->configure(-background => $c); $self->configure(-background => $c); foreach my $child ($self->{CONTAINER}->children) { $child->configure(-background => $c); if ($child->class eq "Button") { $child->configure(-activebackground => $c); } } } sub separator { my $self = shift; my %args = @_; my $move = 1; $move = $args{-movable} if exists $args{-movable}; my $just = $args{-space} || 0; my $f = $self->{CONTAINER}->Frame(-width => $just, -height => 0); my $sep = $self->{CONTAINER}->Frame(qw/ -borderwidth 1 -relief sunken /); $isDummy{$f} = $self->{SIDE}; push @{$self->{WIDGETS}} => $sep; $self->{SEPARATORS}{$sep} = $f; $self->_packWidget($sep); $self->_createSeparatorBindings($sep) if $move; if ($just eq 'right' || $just eq 'bottom') { # just figure out the good width. } return 1; } sub _packWidget { my ($self, $b) = @_; return $self->_packEdge($b) if exists $self->{SEPARATORS}{$b}; my ($side, $pad, $nopad) = $self->{SIDE} =~ /^top$|^bottom$/ ? qw/left -padx -pady/ : qw/top -pady -padx/; if (ref($b) eq 'Tk::LabEntry') { $b->configure(-labelPack => [-side => $side]); } my @extra; if (exists $packIn{$b}) { @extra = (-in => $packIn{$b}); # repack everything now. my $top = $containers{$b}; $top->{SIDE} = $self->{SIDE}; my $e = $top->_edge; my @allSlaves = grep {$_ ne $e} $b->packSlaves; $_ ->packForget for @allSlaves; $top->_packEdge($e, 1); $top->_packWidget($_) for @allSlaves; } if (exists $isDummy{$b}) { # swap width/height if we need to. my ($w, $h); if ($side eq 'left' && $isDummy{$b} =~ /left|right/) { $w = 0; $h = $b->height; } elsif ($side eq 'top' && $isDummy{$b} =~ /top|bottom/) { $w = $b->width; $h = 0; } $b->configure(-width => $h, -height => $w) if defined $w; $isDummy{$b} = $self->{SIDE}; } $b->pack(-side => $side, $pad => 4, $nopad => 0, @extra); } sub _packWidget_old { my ($self, $b) = @_; return $self->_packEdge($b) if exists $self->{SEPARATORS}{$b}; my ($side, $pad, $nopad) = $self->{SIDE} =~ /^top$|^bottom$/ ? qw/left -padx -pady/ : qw/top -pady -padx/; if (ref($b) eq 'Tk::LabEntry') { $b->configure(-labelPack => [-side => $side]); } my @extra; if (exists $packIn{$b}) { @extra = (-in => $packIn{$b}); # repack everything now. my $top = $containers{$b}; $top->{SIDE} = $self->{SIDE}; my $e = $top->_edge; my @allSlaves = grep {$_ ne $e} $b->packSlaves; $_ ->packForget for @allSlaves; $top->_packEdge($e, 1); $top->_packWidget($_) for @allSlaves; } $b->pack(-side => $side, $pad => 4, $nopad => 0, @extra); } sub _configureWidget { my ($self, $w) = @_; $w->configure(-activebackground => $self->{ACTIVE_BG}); } sub _createButtonBindings { my ($self, $b) = @_; my $bg = $b->cget('-bg'); $b->bind('' => [$b, 'configure', qw/-relief raised/]); $b->bind('' => [$b, 'configure', qw/-relief flat/]); } sub _createSeparatorBindings { my ($self, $s) = @_; my ($ox, $oy); $s->bind('<1>' => sub { $ox = $s->XEvent->x; $oy = $s->XEvent->y; }); $s->bind('' => sub { my $x = $s->XEvent->x; my $y = $s->XEvent->y; my $f = $self->{SEPARATORS}{$s}; if ($self->{SIDE} =~ /top|bottom/) { my $dx = $x - $ox; my $w = $f->width + $dx; $w = 0 if $w < 0; $f->GeometryRequest($w, $f->height); } else { my $dy = $y - $oy; my $h = $f->height + $dy; $h = 0 if $h < 0; $f->GeometryRequest($f->width, $h); } }); } sub Button { goto &ToolButton } sub Label { goto &ToolLabel } sub Entry { goto &ToolEntry } sub LabEntry { goto &ToolLabEntry } sub Optionmenu { goto &ToolOptionmenu } sub _clone { my ($self, $top, $in) = @_; my $new = $top->ToolBar(qw/-side top -cursorcontrol/, $self->{USECC}, ($in ? (-in => $in, -movable => 0) : ())); my $e = $self->_edge; my @allSlaves = grep {$_ ne $e} $self->{CONTAINER}->packSlaves; for my $w (@allSlaves) { my $t = ref $w; $t =~ s/Tk:://; if ($t eq 'Frame' && exists $containers{$w}) { # embedded toolbar my $obj = $containers{$w}; $obj->_clone($top, $new); } if ($t eq 'Frame' && exists $self->{SEPARATORS}{$w}) { # separator $new->separator; } my %c = map { $_->[0], $_->[4] || $_->[3] } grep {defined $_->[4] || $_->[3] } grep @$_ > 2, $w->configure; delete $c{$_} for qw/-offset -class -tile -visual -colormap -labelPack/; if ($t =~ /.button/) { $new->Button(-type => $t, %c); } else { $new->$t(%c); } } $new ->{MW} = $self->{MW}; $new ->{CLONE} = $self; $new ->{ISCLONE} = $top; $self->{ISCLONE} = 0; } __END__ =pod =head1 NAME Tk::ToolBar - A toolbar widget for Perl/Tk =for category Tk Widget Classes =head1 SYNOPSIS use Tk; use Tk::ToolBar; my $mw = new MainWindow; my $tb = $mw->ToolBar(qw/-movable 1 -side top -indicatorcolor blue/); $tb->ToolButton (-text => 'Button', -tip => 'tool tip', -command => sub { print "hi\n" }); $tb->ToolLabel (-text => 'A Label'); $tb->Label (-text => 'Another Label'); $tb->ToolLabEntry(-label => 'A LabEntry', -labelPack => [-side => "left", -anchor => "w"]); my $tb2 = $mw->ToolBar; $tb2->ToolButton(-image => 'navback22', -tip => 'back', -command => \&back); $tb2->ToolButton(-image => 'navforward22', -tip => 'forward', -command => \&forward); $tb2->separator; $tb2->ToolButton(-image => 'navhome22', -tip => 'home', -command => \&home); $tb2->ToolButton(-image => 'actreload22', -tip => 'reload', -command => \&reload); MainLoop; =head1 DESCRIPTION This module implements a dockable toolbar. It is in the same spirit as the "short-cut" toolbars found in most major applications, such as most web browsers and text editors (where you find the "back" or "save" and other shortcut buttons). Buttons of any type (regular, menu, check, radio) can be created inside this widget. You can also create Label, Entry and LabEntry widgets. Moreover, the ToolBar itself can be made dockable, such that it can be dragged to any edge of your window. Dragging is done in "real-time" so that you can see the contents of your ToolBar as you are dragging it. Furthermore, if you are close to a stickable edge, a visual indicator will show up along that edge to guide you. ToolBars can be made "floatable" such that if they are dragged beyond their associated window, they will detach and float on the desktop. Also, multiple ToolBars are embeddable inside each other. If you drag a ToolBar to within 15 pixels of an edge, it will stick to that edge. If the ToolBar is further than 15 pixels away from an edge and still inside the window, but you release it over another ToolBar widget, then it will be embedded inside the second ToolBar. You can "un-embed" an embedded ToolBar simply by dragging it out. You can change the 15 pixel limit using the B<-close> option. Various icons are built into the Tk::ToolBar widget. Those icons can be used as images for ToolButtons (see L). A demo program is bundled with the module that should be available under the 'User Contributed Demonstrations' when you run the B program. Run it to see a list of the available images. Tk::ToolBar attempts to use Tk::CursorControl if it's already installed on the system. You can further control this using the I<-cursorcontrol> option. See L. The ToolBar is supposed to be created as a child of a Toplevel (MainWindow is a Toplevel widget) or a Frame. You are free to experiment otherwise, but expect the unexpected :-) =head1 WIDGET-SPECIFIC OPTIONS The ToolBar widget takes the following arguments: =over 4 =item B<-side> This option tells the ToolBar what edge to I stick to. Can be one of 'top', 'bottom', 'left' or 'right'. Defaults to 'top'. This option can be set only during object creation. Default is 'top'. =item B<-movable> This option specifies whether the ToolBar is dockable or not. A dockable ToolBar can be dragged around with the mouse to any edge of the window, subject to the sticky constraints defined by I<-sticky>. Default is 1. =item B<-close> This option specifies, in pixels, how close we have to drag the ToolBar an edge for the ToolBar to stick to it. Default is 15. =item B<-sticky> This option specifies which sides the toolbar is allowed to stick to. The value must be a string of the following characters 'nsew'. A string of 'ns' means that the ToolBar can only stick to the north (top) or south (bottom) sides. Defaults to 'nsew'. This option can be set only during object creation. =item B<-in> This option allows the toolbar to be embedded within another already instantiated Tk::ToolBar object. The value must be a Tk::ToolBar object. This option can be set only during object creation. =item B<-float> This option specifies whether the toolbar should "float" on the desktop if dragged outside of the window. It defaults to 1. Note that this value is ignored if I<-cursorcontrol> is set to 1. =item B<-cursorcontrol> This option specifies whether to use Tk::CursorControl to confine the cursor during dragging. The value must be either 1 or 0. The default is 1 which checks for Tk::CursorControl and uses it if present. =item B<-mystyle> This option indicates that you want to control how the ToolBar looks like and not rely on Tk::ToolBar's own judgement. The value must be either 1 or 0. For now, the only thing this controls is the relief of ToolButtons and the borderwidth. Defaults to 0. =item B<-indicatorcolor> This option controls the color of the visual indicator that tells you whether you are close enough to an edge when dragging the ToolBar. Defaults to some shade of blue and green (I like it :P). =item B<-indicatorrelief> This option controls the relief of the visual indicator that tells you whether you are close enough to an edge when dragging the ToolBar. Defaults to flat. =back =head1 WIDGET METHODS The following methods are used to create widgets that are placed inside the ToolBar. Widgets are ordered in the same order they are created, left to right. For all widgets, except Labels, a tooltip can be specified via the B<-tip> option. An image can be specified using the -image option for Button- and Label-based widgets. =over 4 =item I<$ToolBar>-EB(?-type => I,? I) =item I<$ToolBar>-EB