summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorPascal Rigaux <pixel@mandriva.com>2002-07-31 22:40:00 +0000
committerPascal Rigaux <pixel@mandriva.com>2002-07-31 22:40:00 +0000
commit5a08b6763c4a2efd6da24fc7a3d0149618e086ea (patch)
treedadf7b0060bdf672762e458f936b4e20b7949bfa
parent2c2ac91cdc7f1bd86dfd222fc8edeb4edea46a5d (diff)
downloaddrakx-backup-do-not-use-5a08b6763c4a2efd6da24fc7a3d0149618e086ea.tar
drakx-backup-do-not-use-5a08b6763c4a2efd6da24fc7a3d0149618e086ea.tar.gz
drakx-backup-do-not-use-5a08b6763c4a2efd6da24fc7a3d0149618e086ea.tar.bz2
drakx-backup-do-not-use-5a08b6763c4a2efd6da24fc7a3d0149618e086ea.tar.xz
drakx-backup-do-not-use-5a08b6763c4a2efd6da24fc7a3d0149618e086ea.zip
make perl_checker happy again (replacing "{xx}->{yy}" by "{xx}{yy}")
Diffstat
-rw-r--r--perl-install/Xconfig/various.pm1
-rw-r--r--perl-install/Xconfig/xfreeX.pm2
-rw-r--r--perl-install/bootlook.pm2
-rw-r--r--perl-install/detect_devices.pm10
-rw-r--r--perl-install/diskdrake/interactive.pm2
-rw-r--r--perl-install/install_any.pm12
-rw-r--r--perl-install/network/ethernet.pm6
-rw-r--r--perl-install/network/netconnect.pm18
-rw-r--r--perl-install/network/network.pm2
-rw-r--r--perl-install/printer.pm42
-rw-r--r--perl-install/resize_fat/info_sector.pm2
-rw-r--r--perl-install/resize_fat/main.pm4
12 files changed, 52 insertions, 51 deletions
diff --git a/perl-install/Xconfig/various.pm b/perl-install/Xconfig/various.pm
index 0089acd30..e24416e01 100644
--- a/perl-install/Xconfig/various.pm
+++ b/perl-install/Xconfig/various.pm
@@ -4,6 +4,7 @@ use diagnostics;
use strict;
use Xconfig::card;
+use Xconfig::default;
use Xconfig::resolution_and_depth;
use common;
use any;
diff --git a/perl-install/Xconfig/xfreeX.pm b/perl-install/Xconfig/xfreeX.pm
index f6aa17f78..1112c2234 100644
--- a/perl-install/Xconfig/xfreeX.pm
+++ b/perl-install/Xconfig/xfreeX.pm
@@ -87,7 +87,7 @@ sub get_devices {
map {
my $raw_device = $_;
my $device = raw_export_section($raw_device, [ 'Identifier', $raw_X->get_device_section_fields ]);
- $device->{Options} = raw_export_section($raw_device, [ grep { (deref_array($raw_device->{$_}))[0]->{Option} } keys %$raw_device ]);
+ $device->{Options} = raw_export_section($raw_device, [ grep { (deref_array($raw_device->{$_}))[0]{Option} } keys %$raw_device ]);
$device;
} @raw_devices;
}
diff --git a/perl-install/bootlook.pm b/perl-install/bootlook.pm
index b94250e39..213736059 100644
--- a/perl-install/bootlook.pm
+++ b/perl-install/bootlook.pm
@@ -98,7 +98,7 @@ my $x_box = new Gtk::VBox(0, 0);
my $disp_mode = arch() =~ /ppc/ ? _("Yaboot mode") : _("Lilo/grub mode");
gtkadd($window,
gtkpack__ (my $global_vbox = new Gtk::VBox(0,0),
- gtkadd (new Gtk::Frame ("$disp_mode"),
+ gtkadd (new Gtk::Frame ($disp_mode),
# gtkpack__(new Gtk::VBox(0,0),
(gtkpack_(gtkset_border_width(new Gtk::HBox(0, 0),5),
1,_("You are currently using %s as your boot manager.
diff --git a/perl-install/detect_devices.pm b/perl-install/detect_devices.pm
index 5937c7c83..4514d5f5e 100644
--- a/perl-install/detect_devices.pm
+++ b/perl-install/detect_devices.pm
@@ -153,10 +153,10 @@ sub isDvdDrive {
my $f = tryOpen($e->{device});
$f && c::isDvdDrive(fileno($f));
}
-sub isZipDrive { $_[0]->{info} =~ /ZIP\s+\d+/ } #- accept ZIP 100, untested for bigger ZIP drive.
-sub isJazzDrive { $_[0]->{info} =~ /\bJAZZ?\b/i } #- accept "iomega jaz 1GB"
-sub isLS120Drive { $_[0]->{info} =~ /LS-?120|144MB/ }
-sub isRemovableDrive { &isZipDrive || &isLS120Drive || $_[0]->{media_type} eq 'fd' } #-or &isJazzDrive }
+sub isZipDrive { $_[0]{info} =~ /ZIP\s+\d+/ } #- accept ZIP 100, untested for bigger ZIP drive.
+sub isJazzDrive { $_[0]{info} =~ /\bJAZZ?\b/i } #- accept "iomega jaz 1GB"
+sub isLS120Drive { $_[0]{info} =~ /LS-?120|144MB/ }
+sub isRemovableDrive { &isZipDrive || &isLS120Drive || $_[0]{media_type} eq 'fd' } #-or &isJazzDrive }
sub isFloppyOrHD {
my ($dev) = @_;
@@ -656,7 +656,7 @@ sub getSNMPModel {
sub whatNetPrinter () {
my $i;
- my @res = ();
+ my @res;
# Scan network for printers (one of ports 9100-9199 open)
local *F;
diff --git a/perl-install/diskdrake/interactive.pm b/perl-install/diskdrake/interactive.pm
index fe5e897c4..fa3593d89 100644
--- a/perl-install/diskdrake/interactive.pm
+++ b/perl-install/diskdrake/interactive.pm
@@ -1161,7 +1161,7 @@ sub format_raw_hd_info {
#- get the minimal size of partition in sectors to help diskdrake on
#- limit cases, include a cylinder + start of a eventually following
#- logical partition.
-sub min_partition_size { $_[0]->cylinder_size() + 2*$_[0]->{geom}{sectors} }
+sub min_partition_size { $_[0]->cylinder_size() + 2*$_[0]{geom}{sectors} }
sub choose_encrypt_key {
diff --git a/perl-install/install_any.pm b/perl-install/install_any.pm
index 8159ffe19..a69e8c0c6 100644
--- a/perl-install/install_any.pm
+++ b/perl-install/install_any.pm
@@ -1170,7 +1170,7 @@ sub what_provides {
sub is_installed {
my ($do, @l) = @_;
foreach (@l) {
- my $p = pkgs::packageByName($do->{o}->{packages}, $_);
+ my $p = pkgs::packageByName($do->{o}{packages}, $_);
$p && $p->flag_selected or return;
}
1;
@@ -1180,25 +1180,25 @@ sub remove {
my ($do, @l) = @_;
@l = grep {
- my $p = pkgs::packageByName($do->{o}->{packages}, $_);
- pkgs::unselectPackage($do->{o}->{packages}, $p) if $p;
+ my $p = pkgs::packageByName($do->{o}{packages}, $_);
+ pkgs::unselectPackage($do->{o}{packages}, $p) if $p;
$p;
} @l;
- run_program::rooted($do->{o}->{prefix}, 'rpm', '-e', @l);
+ run_program::rooted($do->{o}{prefix}, 'rpm', '-e', @l);
}
sub remove_nodeps {
my ($do, @l) = @_;
@l = grep {
- my $p = pkgs::packageByName($do->{o}->{packages}, $_);
+ my $p = pkgs::packageByName($do->{o}{packages}, $_);
if ($p) {
$p->set_flag_requested(0);
$p->set_flag_required(0);
}
$p;
} @l;
- run_program::rooted($do->{o}->{prefix}, 'rpm', '-e', '--nodeps', @l);
+ run_program::rooted($do->{o}{prefix}, 'rpm', '-e', '--nodeps', @l);
}
################################################################################
diff --git a/perl-install/network/ethernet.pm b/perl-install/network/ethernet.pm
index aa2339fe2..8a71f60c7 100644
--- a/perl-install/network/ethernet.pm
+++ b/perl-install/network/ethernet.pm
@@ -87,7 +87,7 @@ sub conf_network_card {
my $interface;
@all_cards == () and $in->ask_warn('', _("No ethernet network adapter has been detected on your system.
I cannot set up this connection type.")) and return;
- @all_cards == 1 and $interface = $all_cards[0]->[0] and goto l1;
+ @all_cards == 1 and $interface = $all_cards[0][0] and goto l1;
again :
$interface = $in->ask_from_list(_("Choose the network interface"),
_("Please choose which network adapter you want to use to connect to Internet"),
@@ -155,7 +155,7 @@ sub conf_network_card_backend {
@{$intf->{$device}}{qw(DEVICE BOOTPROTO NETMASK NETWORK ONBOOT)} =
($device, $type, '255.255.255.0', $netadr, 'yes');
- $intf->{$device}->{IPADDR} = $ipadr if $ipadr;
+ $intf->{$device}{IPADDR} = $ipadr if $ipadr;
$device;
}
@@ -185,7 +185,7 @@ sub configureNetwork {
my $intf2 = findIntf($intf ||= {}, $_);
add2hash($intf2, $last);
add2hash($intf2, { NETMASK => '255.255.255.0' });
- configureNetworkIntf($netc, $in, $intf2, $netc->{NET_DEVICE}, 0, $all_cards[$n_card]->[1]) or return;
+ configureNetworkIntf($netc, $in, $intf2, $netc->{NET_DEVICE}, 0, $all_cards[$n_card][1]) or return;
$last = $intf2;
$n_card++;
diff --git a/perl-install/network/netconnect.pm b/perl-install/network/netconnect.pm
index 8aef0b3c8..3bfc02768 100644
--- a/perl-install/network/netconnect.pm
+++ b/perl-install/network/netconnect.pm
@@ -373,7 +373,7 @@ DNSThirdIP=$netc->{dnsServer3}
AdminInterface=
" . join ('', map {
-"Eth${_}Known=" . ($intf->{"eth$_"}->{DEVICE} eq "eth$_" ? 'true' : 'false') . "
+"Eth${_}Known=" . ($intf->{"eth$_"}{DEVICE} eq "eth$_" ? 'true' : 'false') . "
Eth${_}IP=" . $intf->{"eth$_"}{IPADDR} . "
Eth${_}Mask=" . $intf->{"eth$_"}{NETMASK} . "
Eth${_}Mac=
@@ -381,7 +381,7 @@ Eth${_}BootProto=" . $intf->{"eth$_"}{BOOTPROTO} . "
Eth${_}OnBoot=" . $intf->{"eth$_"}{ONBOOT} . "
Eth${_}Hostname=$netc->{HOSTNAME}
Eth${_}HostAlias=" . do { $netc->{HOSTNAME} =~ /([^\.]*)\./; $1 } . "
-Eth${_}Driver=$all_cards[$_]->[1]
+Eth${_}Driver=$all_cards[$_][1]
Eth${_}Irq=
Eth${_}Port=
Eth${_}DHCPClient=" . ($intf->{"eth$_"}{BOOTPROTO} eq 'dhcp' ? $netcnx->{dhcp_client} : '') . "
@@ -528,13 +528,13 @@ sub load_conf {
/^InternetGateway=(.*)$/ and $netc->{GATEWAY} = $1;
/^SystemName=(.*)$/ and $system_name = $1;
/^DomainName=(.*)$/ and $domain_name = $1;
- /^Eth([0-9])Known=true$/ and $intf->{"eth$1"}->{DEVICE} = "eth$1";
- /^Eth([0-9])IP=(.*)$/ && $intf->{"eth$1"}->{DEVICE} and $intf->{"eth$1"}{IPADDR} = $2;
- /^Eth([0-9])Mask=(.*)\n/ && $intf->{"eth$1"}->{DEVICE} and $intf->{"eth$1"}{NETMASK} = $2;
- /^Eth([0-9])BootProto=(.*)\n/ && $intf->{"eth$1"}->{DEVICE} and $intf->{"eth$1"}{BOOTPROTO} = $2;
- /^Eth([0-9])OnBoot=(.*)\n/ && $intf->{"eth$1"}->{DEVICE} and $intf->{"eth$1"}{ONBOOT} = $2;
- /^Eth([0-9])Hostname=(.*)\n/ && $intf->{"eth$1"}->{DEVICE} and $netc->{HOSTNAME} = $2;
- /^Eth([0-9])Driver=(.*)\n/ && $intf->{"eth$1"}->{DEVICE} and $intf->{"eth$1"}{driver} = $2;
+ /^Eth([0-9])Known=true$/ and $intf->{"eth$1"}{DEVICE} = "eth$1";
+ /^Eth([0-9])IP=(.*)$/ && $intf->{"eth$1"}{DEVICE} and $intf->{"eth$1"}{IPADDR} = $2;
+ /^Eth([0-9])Mask=(.*)\n/ && $intf->{"eth$1"}{DEVICE} and $intf->{"eth$1"}{NETMASK} = $2;
+ /^Eth([0-9])BootProto=(.*)\n/ && $intf->{"eth$1"}{DEVICE} and $intf->{"eth$1"}{BOOTPROTO} = $2;
+ /^Eth([0-9])OnBoot=(.*)\n/ && $intf->{"eth$1"}{DEVICE} and $intf->{"eth$1"}{ONBOOT} = $2;
+ /^Eth([0-9])Hostname=(.*)\n/ && $intf->{"eth$1"}{DEVICE} and $netc->{HOSTNAME} = $2;
+ /^Eth([0-9])Driver=(.*)\n/ && $intf->{"eth$1"}{DEVICE} and $intf->{"eth$1"}{driver} = $2;
/^ISDNDriver=(.*)$/ and $isdn->{driver} = $1;
/^ISDNDeviceType=(.*)$/ and $isdn->{type} = $1;
/^ISDNIrq=(.*)/ and $isdn->{irq} = $1;
diff --git a/perl-install/network/network.pm b/perl-install/network/network.pm
index 880b23aa6..4305d6011 100644
--- a/perl-install/network/network.pm
+++ b/perl-install/network/network.pm
@@ -207,7 +207,7 @@ sub dnsServers {
sub findIntf {
my ($intf, $device) = @_;
- $intf->{$device}->{DEVICE} = $device;
+ $intf->{$device}{DEVICE} = $device;
$intf->{$device};
}
#PAD \s* a la fin
diff --git a/perl-install/printer.pm b/perl-install/printer.pm
index ce3d02d5e..f780963af 100644
--- a/perl-install/printer.pm
+++ b/perl-install/printer.pm
@@ -473,44 +473,44 @@ sub read_configured_queues($) {
my $i;
my $N = $#QUEUES + 1;
for ($i = 0; $i < $N; $i++) {
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}} =
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}} =
$QUEUES[$i];
- if ((!$QUEUES[$i]->{make}) || (!$QUEUES[$i]->{model})) {
+ if ((!$QUEUES[$i]{make}) || (!$QUEUES[$i]{model})) {
if ($printer->{SPOOLER} eq "cups") {
- $printer->{OLD_QUEUE} = $QUEUES[$i]->{queuedata}{queue};
+ $printer->{OLD_QUEUE} = $QUEUES[$i]{queuedata}{queue};
my $descr = get_descr_from_ppd($printer);
$descr =~ m/^([^\|]*)\|([^\|]*)\|.*$/;
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{make} ||= $1;
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{model} ||= $2;
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{make} ||= $1;
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{model} ||= $2;
# Read out which PPD file was originally used to set up this
# queue
local *F;
- if (open F, "< $prefix/etc/cups/ppd/$QUEUES[$i]->{queuedata}{queue}.ppd") {
+ if (open F, "< $prefix/etc/cups/ppd/$QUEUES[$i]{queuedata}{queue}.ppd") {
while (my $line = <F>) {
if ($line =~ /^\*%MDKMODELCHOICE:(.+)$/) {
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{ppd} = $1;
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{ppd} = $1;
}
}
close F;
}
# Mark that we have a CUPS queue but do not know the name
# the PPD file in /usr/share/cups/model
- if (!$printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{ppd}) {
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{ppd} = '1';
+ if (!$printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{ppd}) {
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{ppd} = '1';
}
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{driver} = 'CUPS/PPD';
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{driver} = 'CUPS/PPD';
$printer->{OLD_QUEUE} = "";
# Read out the printer's options
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{args} = read_cups_options($QUEUES[$i]->{queuedata}{queue});
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{args} = read_cups_options($QUEUES[$i]{queuedata}{queue});
}
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{make} ||= "";
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{model} ||= _("Unknown model");
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{make} ||= "";
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{model} ||= _("Unknown model");
} else {
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{make} = $QUEUES[$i]->{make};
- $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{model} = $QUEUES[$i]->{model};
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{make} = $QUEUES[$i]{make};
+ $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{model} = $QUEUES[$i]{model};
}
# Fill in "options" field
- if (my $args = $printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{args}) {
+ if (my $args = $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{args}) {
my $arg;
my @options;
for $arg (@{$args}) {
@@ -518,11 +518,11 @@ sub read_configured_queues($) {
my $optstr = $arg->{name} . "=" . $arg->{default};
push(@options, $optstr);
}
- @{$printer->{configured}{$QUEUES[$i]->{queuedata}{queue}}{queuedata}{options}} = @options;
+ @{$printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{options}} = @options;
}
# Construct an entry line for tree view in main window of
# printerdrake
- make_menuentry($printer, $QUEUES[$i]->{queuedata}{queue});
+ make_menuentry($printer, $QUEUES[$i]{queuedata}{queue});
}
}
@@ -647,7 +647,7 @@ sub read_printer_db(;$) {
$entry->{ENTRY} = "$entry->{make}|$entry->{model}|$driverstr";
$entry->{driver} = $driver;
# Duplicate contents of $entry because it is multiply entered to the database
- map { $thedb{$entry->{ENTRY}}->{$_} = $entry->{$_} } keys %$entry;
+ map { $thedb{$entry->{ENTRY}}{$_} = $entry->{$_} } keys %$entry;
}
} else {
# Recommended mode
@@ -656,7 +656,7 @@ sub read_printer_db(;$) {
$entry->{ENTRY} = "$entry->{make}|$entry->{model}";
if ($entry->{defaultdriver}) {
$entry->{driver} = $entry->{defaultdriver};
- map { $thedb{$entry->{ENTRY}}->{$_} = $entry->{$_} } keys %$entry;
+ map { $thedb{$entry->{ENTRY}}{$_} = $entry->{$_} } keys %$entry;
}
}
$entry = {};
@@ -696,7 +696,7 @@ sub read_printer_db(;$) {
$entry->{driver} = "raw";
$entry->{make} = "";
$entry->{model} = _("Unknown model");
- map { $thedb{$entry->{ENTRY}}->{$_} = $entry->{$_} } keys %$entry;
+ map { $thedb{$entry->{ENTRY}}{$_} = $entry->{$_} } keys %$entry;
}
#- Load CUPS driver database if CUPS is used as spooler
diff --git a/perl-install/resize_fat/info_sector.pm b/perl-install/resize_fat/info_sector.pm
index 35449cedc..11aa7f153 100644
--- a/perl-install/resize_fat/info_sector.pm
+++ b/perl-install/resize_fat/info_sector.pm
@@ -28,7 +28,7 @@ sub read($) {
sub write($) {
my ($fs) = @_;
- $fs->{info_sector}{free_clusters} = $fs->{clusters}->{count}->{free};
+ $fs->{info_sector}{free_clusters} = $fs->{clusters}{count}{free};
$fs->{info_sector}{next_cluster} = 2;
my $info = pack $format, @{$fs->{info_sector}}{@fields};
diff --git a/perl-install/resize_fat/main.pm b/perl-install/resize_fat/main.pm
index 5a4810ed3..dd3e720e5 100644
--- a/perl-install/resize_fat/main.pm
+++ b/perl-install/resize_fat/main.pm
@@ -147,8 +147,8 @@ sub resize {
$fs->{nb_sectors} = $size;
$fs->{nb_clusters} = $new_nb_clusters;
- $fs->{clusters}{count}->{free} =
- $fs->{nb_clusters} - $fs->{clusters}{count}->{used} - $fs->{clusters}->{count}->{bad} - 2;
+ $fs->{clusters}{count}{free} =
+ $fs->{nb_clusters} - $fs->{clusters}{count}{used} - $fs->{clusters}{count}{bad} - 2;
$fs->{system_id} = 'was here!';
$fs->{small_nb_sectors} = 0;
generated by cgit v1.2.1 (git 2.21.0) at 2024-10-23 22:49:31 +0000
n>$@) { my $w = shift; $w->signal_connect(@_); $w } sub gtkpack($@) { my $box = shift; gtkpack_($box, map {; 1, $_ } @_); } sub gtkpack__($@) { my $box = shift; gtkpack_($box, map {; 0, $_ } @_); } sub gtkpack_($@) { my $box = shift; for (my $i = 0; $i < @_; $i += 2) { my $l = $_[$i + 1]; ref $l or $l = new Gtk::Label($l); $box->pack_start($l, $_[$i], 1, 0); $l->show; } $box } sub gtkappend($@) { my $w = shift; foreach (@_) { my $l = $_; ref $l or $l = new Gtk::Label($l); $w->append($l); $l->show; } $w } sub gtkadd($@) { my $w = shift; foreach (@_) { my $l = $_; ref $l or $l = new Gtk::Label($l); $w->add($l); $l->show; } $w } sub gtktext_insert($$) { my ($w, $t) = @_; $w->freeze; $w->backward_delete($w->get_length); $w->insert(undef, undef, undef, "$t\n"); #- needs \n otherwise in case of one line text the beginning is not shown (even with the vadj->set_value) $w->set_word_wrap(1); #- $w->vadj->set_value(0); $w->thaw; $w; } sub gtkroot { Gtk->init; Gtk::Gdk::Window->new_foreign(Gtk::Gdk->ROOT_WINDOW); } sub gtkcolor($$$) { my ($r, $g, $b) = @_; my $color = bless { red => $r, green => $g, blue => $b }, 'Gtk::Gdk::Color'; gtkroot()->get_colormap->color_alloc($color); } sub gtkset_mousecursor($) { my ($type) = @_; gtkroot()->set_cursor(Gtk::Gdk::Cursor->new($type)); } sub gtkset_background { my ($r, $g, $b) = @_; my $root = gtkroot(); my $gc = Gtk::Gdk::GC->new($root); my $color = gtkcolor($r, $g, $b); $gc->set_foreground($color); $root->set_background($color); my ($h, $w) = $root->get_size; $root->draw_rectangle($gc, 1, 0, 0, $w, $h); } sub gtkset_default_fontset($) { my ($fontset) = @_; my $style = Gtk::Widget->get_default_style; my $f = Gtk::Gdk::Font->fontset_load($fontset) or die ''; $style->font($f); Gtk::Widget->set_default_style($style); } sub gtkcreate_xpm { my $w = shift; Gtk::Gdk::Pixmap->create_from_xpm($w->window, $w->style->bg('normal'), @_) } sub xpm_d { my $w = shift; Gtk::Gdk::Pixmap->create_from_xpm_d($w->window, undef, @_) } sub gtkxpm { new Gtk::Pixmap(gtkcreate_xpm(@_)) } #-############################################################################### #- createXXX functions #- these functions return a widget #-############################################################################### sub create_okcancel($;$$) { my ($w, $ok, $cancel) = @_; gtkadd(create_hbox(), gtksignal_connect($w->{ok} = new Gtk::Button($ok || _("Ok")), "clicked" => $w->{ok_clicked} || sub { $w->{retval} = 1; Gtk->main_quit }), ($ok xor $cancel) ? () : gtksignal_connect(new Gtk::Button($cancel || _("Cancel")), "clicked" => $w->{cancel_clicked} || sub { $w->{retval} = 0; Gtk->main_quit }), ); } sub create_box_with_title($@) { my $o = shift; $o->{box} = (@_ <= 2 && (map { split "\n" } @_) > 6) ? gtkpack(new Gtk::VBox(0,0), gtkset_usize(createScrolledWindow(gtktext_insert(new Gtk::Text, join "\n", @_)), 400, 250)) : gtkpack_(new Gtk::VBox(0,0), (map { my $w = ref $_ ? $_ : new Gtk::Label($_); $w->set_name("Title"); 0, $w; } map { ref $_ ? $_ : warp_text($_) } @_), 0, new Gtk::HSeparator, ); } sub createScrolledWindow($) { my ($W) = @_; my $w = new Gtk::ScrolledWindow(undef, undef); $w->set_policy('automatic', 'automatic'); member(ref $W, qw(Gtk::CList Gtk::CTree Gtk::Text)) ? $w->add($W) : $w->add_with_viewport($W); $W->can("set_focus_vadjustment") and $W->set_focus_vadjustment($w->get_vadjustment); $W->show; $w } sub create_menu($@) { my $title = shift; my $w = new Gtk::MenuItem($title); $w->set_submenu(gtkshow(gtkappend(new Gtk::Menu, @_))); $w } sub add2notebook { my ($n, $title, $book) = @_; my ($w1, $w2) = map { new Gtk::Label($_) } $title, $title; $book->{widget_title} = $w1; $n->append_page_menu($book, $w1, $w2); $book->show; $w1->show; $w2->show; } sub create_notebook(@) { my $n = new Gtk::Notebook; add2notebook($n, splice(@_, 0, 2)) while @_; $n } sub create_adjustment($$$) { my ($val, $min, $max) = @_; new Gtk::Adjustment($val, $min, $max + 1, 1, ($max - $min + 1) / 10, 1); } sub create_packtable($@) { my $options = shift; my $w = new Gtk::Table(0, 0, $options->{homogeneous} || 0); map_index { my ($i) = @_; map_index { my ($j) = @_; if (defined $_) { ref $_ or $_ = new Gtk::Label($_); $w->attach_defaults($_, $j, $j + 1, $i, $i + 1); $_->show; } } @$_; } @_; $w->set_col_spacings($options->{col_spacings} || 0); $w->set_row_spacings($options->{row_spacings} || 0); $w } sub create_hbox { my $w = new Gtk::HButtonBox; $w->set_layout(-spread); $w; } sub create_vbox { my $w = new Gtk::VButtonBox; $w->set_layout(-spread); $w; } sub _create_window($$) { my ($o, $title) = @_; my $w = new Gtk::Window; my $f = new Gtk::Frame(undef); $w->set_name("Title"); if ($::isStandalone || $o->{no_border} || 1) { # hack gtkadd($w, $f); } else { my $t = new Gtk::Table(0, 0, 0); my $new = sub { my $w = new Gtk::DrawingArea; $w->set_usize($border, $border); $w->set_events(['exposure_mask']); $w->signal_connect_after(expose_event => sub { $w->window->draw_rectangle($w->style->black_gc, 1, 0, 0, @{$w->allocation}[2,3]); 1 }