view release on metacpan or  search on metacpan

lib/Tk/Playlist.pm  view on Meta::CPAN

#!perl -w
#
# Tk::Playlist class - provides winamp-style "playlist" editing capibilities.
#
# By Tyler "Crackerjack" MacDonald <crackerjack@crackerjack.net>
# July 23rd, 2000.
# Package-ified November 25, 2004.
#
# This module is freeware; You may redistribute it under the same terms as
# perl itself.
#

package Tk::Playlist;

use 5.005;
use strict;
use vars qw($VERSION @ISA);

use Tk;
use Tk::Derived;
use Tk::HList;

$VERSION = '0.01';
@ISA=qw(Tk::Derived Tk::HList);

Construct Tk::Widget 'Playlist';

sub Tk::Widget::ScrolledPlaylist { shift->Scrolled('Playlist'=>@_); }

return 1;

sub ClassInit
{
 my($class,$mw)=@_;

 $mw->eventAdd('<<Toggle>>' => '<Control-ButtonPress-1>');
 $mw->eventAdd('<<RangeSelect>>' => '<Shift-ButtonPress-1>');
 $mw->eventAdd('<<MoveEntries>>' => '<B1-Motion>');
 $mw->eventAdd('<<InverseSelect>>' => '<Control-ButtonPress-2>');
 $mw->eventAdd('<<SingleSelect>>' => '<ButtonPress-1>');
 $mw->eventAdd('<<EndMovement>>' => '<ButtonRelease-1>');
 $mw->eventAdd('<<Delete>>' => '<Key-Delete>');

 $mw->bind($class, '<<Toggle>>', [ 'Toggle' ]);
 $mw->bind($class, '<<SingleSelect>>', [ 'SingleSelect' ]);
 $mw->bind($class, '<<RangeSelect>>', [ 'RangeSelect' ]);
 $mw->bind($class, '<<MoveEntries>>', [ 'MoveEntries' ]);
 $mw->bind($class, '<<EndMovement>>', [ 'EndMovement' ]);
 $mw->bind($class, '<<Delete>>', [ 'Delete' ]);

# $class->SUPER::ClassInit($mw);
}

sub Populate
{
 my($cw,$args)=@_;
 my $f;

 $cw->ConfigSpecs('-style'=>['PASSIVE', undef, undef, undef]);
 $cw->ConfigSpecs('-readonly'=>['METHOD', undef, undef, undef]);
 $cw->ConfigSpecs('-callback_change'=>['METHOD', undef, undef, undef]);

 $cw->SUPER::Populate($args);
}

sub Delete
{
 my($cw)=@_;

 return if($cw->{'readonly'});

 my @is=$cw->infoSelection();
 grep($cw->deleteEntry($_),@is);

 if($cw->{'callback_change'})
 {
  my($cmd,@arg);
  if(ref($cw->{'callback_change'}) eq 'ARRAY')
  {
   ($cmd,@arg)=@{$cw->{'callback_change'}};
  }
  elsif(ref($cw->{'callback_change'}) eq 'CODE')
  {
   ($cmd,@arg)=($cw->{'callback_change'});