← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to Tk.pm

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
Tk.pm
1
1
#
2
2
# Copyright (c) 1992-1994 The Regents of the University of California.
3
3
# Copyright (c) 1994 Sun Microsystems, Inc.
4
 
# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
 
4
# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
5
5
# This program is free software; you can redistribute it and/or
6
6
 
7
7
# modify it under the same terms as Perl itself, subject
53
53
# is created, $VERSION is checked by bootstrap
54
54
$Tk::version     = '8.0';
55
55
$Tk::patchLevel  = '8.0';
56
 
$Tk::VERSION     = '800.024';
 
56
$Tk::VERSION     = '800.025';
57
57
$Tk::XS_VERSION  = $Tk::VERSION;
58
58
$Tk::strictMotif = 0;
59
59
 
136
136
 
137
137
sub Ev
138
138
{
139
 
 my @args = @_;
140
 
 my $obj;
141
 
 if (@args == 1)
 
139
 if (@_ == 1)
142
140
  {
143
 
   my $arg = pop(@args);
144
 
   $obj = (ref $arg) ? $arg : \$arg;
 
141
   my $arg = $_[0];
 
142
   return bless (((ref $arg) ? $arg : \$arg), 'Tk::Ev');
145
143
  }
146
144
 else
147
145
  {
148
 
   $obj = \@args;
 
146
   return bless [@_],'Tk::Ev';
149
147
  }
150
 
 return bless $obj,'Tk::Ev';
151
148
}
152
149
 
153
150
sub InitClass
247
244
                      split(/(abort|retry|ignore|yes|no|cancel|ok)/,
248
245
                            lc($type))));
249
246
        $args->{-buttons} = [@buttons];
250
 
        $args->{-default_button} = delete $args->{-default} if
 
247
        $args->{-default_button} = ucfirst(delete $args->{-default}) if
251
248
            defined $args->{-default};
252
249
        if (not defined $args->{-default_button} and scalar(@buttons) == 1) {
253
250
           $args->{-default_button} = $buttons[0];
262
259
sub messageBox
263
260
{
264
261
 my ($widget,%args) = @_;
265
 
 $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok';
266
 
 tk_messageBox(-parent => $widget, %args);
 
262
 # remove in a later version:
 
263
 if (exists $args{'-text'})
 
264
  {
 
265
   warn "The -text option is deprecated. Please use -message instead";
 
266
   if (!exists $args{'-message'})
 
267
    {
 
268
     $args{'-message'} = delete $args{'-text'};
 
269
    }
 
270
  }
 
271
 $args{'-type'}    = (exists $args{'-type'})    ? lc($args{'-type'}) : 'ok';
 
272
 $args{'-default'} = lc($args{'-default'}) if (exists $args{'-default'});
 
273
 ucfirst tk_messageBox(-parent => $widget, %args);
267
274
}
268
275
 
269
276
sub getOpenFile
358
365
 local $_ = shift;
359
366
 unless (defined $Home)
360
367
  {
361
 
   $Home = $ENV{'HOME'} || ($ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'});
 
368
   $Home = $ENV{'HOME'} || (defined $ENV{'HOMEDRIVE'} && defined $ENV{'HOMEPATH'} ? $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'} : "");
362
369
   $Home =~ s#\\#/#g;
363
370
   $Home .= '/' unless $Home =~ m#/$#;
364
371
  }