1# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. 2# This program is free software; you can redistribute it and/or 3# modify it under the same terms as Perl itself. 4package Tk::Image; 5 6# This module does for images what Tk::Widget does for widgets: 7# provides a base class for them to inherit from. 8require DynaLoader; 9 10use base qw(DynaLoader Tk); # but are they ? 11 12use vars qw($VERSION); 13$VERSION = '4.011'; # $Id: //depot/Tkutf8/Tk/Image.pm#11 $ 14 15sub new 16{ 17 my $package = shift; 18 my $widget = shift; 19 $package->InitClass($widget); 20 my $leaf = $package->Tk_image; 21 my $obj = $widget->Tk::image('create',$leaf,@_); 22 $obj = $widget->_object($obj) unless (ref $obj); 23 return bless $obj,$package; 24} 25 26sub Install 27{ 28 # Dynamically loaded image types can install standard images here 29 my ($class,$mw) = @_; 30} 31 32sub ClassInit 33{ 34 # Carry out class bindings (or whatever) 35 my ($package,$mw) = @_; 36 return $package; 37} 38 39require Tk::Submethods; 40 41Direct Tk::Submethods ('image' => [qw(delete width height inuse type)]); 42 43sub Tk::Widget::imageNames 44{ 45 my $w = shift; 46 $w->image('names',@_); 47} 48 49sub Tk::Widget::imageTypes 50{ 51 my $w = shift; 52 map("\u$_",$w->image('types',@_)); 53} 54 55sub Construct 56{ 57 my ($base,$name) = @_; 58 my $class = (caller(0))[0]; 59 60 # Hack for broken ->isa in perl5.6.0 61 delete ${"$class\::"}{'::ISA::CACHE::'} if $] == 5.006; 62 63 *{"Tk::Widget::$name"} = sub { $class->new(@_) }; 64} 65 66# This is here to prevent AUTOLOAD trying to find it. 67sub DESTROY 68{ 69 my $i = shift; 70 # maybe do image delete ??? 71} 72 73 741; 75