package any; # $Id$
use diagnostics;
use strict;
#-######################################################################################
#- misc imports
#-######################################################################################
use common;
use detect_devices;
use partition_table qw(:types);
use fsedit;
use fs;
use lang;
use run_program;
use keyboard;
use devices;
use modules;
use log;
use c;
sub drakx_version() {
$::move ? sprintf "DrakX-move v%s", cat_('/usr/bin/stage2/move.pm') =~ /move\.pm,v (\S+ \S+ \S+)/
: sprintf "DrakX v%s built %s", $::testing ? ('TEST', scalar gmtime()) : (split('/', cat_("$ENV{SHARE_PATH}/VERSION")))[2,3];
}
sub facesdir() {
"$::prefix/usr/share/mdk/faces/";
}
sub face2png {
my ($face) = @_;
facesdir() . $face . ".png";
}
sub facesnames() {
my $dir = facesdir();
my @l = grep { /^[A-Z]/ } all($dir);
map { if_(/(.*)\.png/, $1) } (@l ? @l : all($dir));
}
sub addKdmIcon {
my ($user, $icon) = @_;
my $dest = "$::prefix/usr/share/faces/$user.png";
eval { cp_af(facesdir() . $icon . ".png", $dest) } if $icon;
}
sub allocUsers {
my ($users) = @_;
my @m = my @l = facesnames();
foreach (grep { !$_->{icon} || $_->{icon} eq "automagic" } @$users) {
$_->{auto_icon} = splice(@m, rand(@m), 1); #- known biased (see cookbook for better)
log::l("auto_icon is $_->{auto_icon}");
@m = @l unless @m;
}
}
sub addUsers {
my ($users) = @_;
allocUsers($users);
foreach my $u (@$users) {
run_program::rooted($::prefix, "usermod", "-G", join(",", @{$u->{groups}}), $u->{name}) if !is_empty_array_ref($u->{groups});
addKdmIcon($u->{name}, delete $u->{auto_icon} || $u->{icon});
}
}
sub crypt {
my ($password, $md5) = @_;
crypt($password, $md5 ? '$1$' . salt(8) : salt(2));
}
sub enableShadow() {
run_program::rooted($::prefix, "pwconv") or log::l("pwconv failed");
run_program::rooted($::prefix, "grpconv") or log::l("grpconv failed");
}
sub hdInstallPath() {
my $tail = first(readlink("/tmp/image") =~ m|^/tmp/hdimage/?(.*)|);
my $head = first(readlink("/tmp/hdimage") =~ m|$::prefix(.*)|);
defined $tail && ($head ? "$head/$tail" : "/mnt/hd/$tail");
}
sub kernelVersion() {
my $kernel = readlink("$::prefix/boot/vmlinuz") || first(all("$::prefix/boot"));
first($kernel =~ /vmlinuz-(.*)/);
}
sub setupBootloader {
my ($in, $b, $all_hds, $fstab, $security) = @_;
my $hds = $all_hds->{hds};
require bootloader;
general:
{
local $::Wizard_no_previous = 1 if $::isStandalone;
setupBootloader__general($in, $b, $all_hds, $fstab, $security) or return 0;
}
setupBootloader__boot_bios_drive($in, $b, $hds) or goto general;
{
local $::Wizard_finished = 1 if $::isStandalone;
setupBootloader__entries($in, $b, $all_hds, $fstab) or goto general;
}
#- somewhere should bootloader really installed ?
$::isStandalone and my $_w = $in->wait_message(N("Please wait"), N("Bootloader installation in progress"));
eval { run_program::rooted($::prefix, 'lilo', '-u') } if $::isInstall && !$::o->{isUpgrade} && -e "$::prefix/etc/lilo.conf" && glob("$::prefix/boot/boot.*");
bootloader::install($b, $fstab, $hds);
}
sub setupBootloader_simple {
my ($in, $b, $all_hds, $fstab, $security) = @_;
my $hds = $all_hds->{hds};
require bootloader;
my $mixed_kind_of_disks = bootloader::mixed_kind_of_disks($hds);
#- full expert questions when there is 2 kind of disks
#- it would need a semi_auto asking on which drive the bios boots...
$mixed_kind_of_disks || $b->{bootUnsafe} || arch() =~ /ppc/ or return 1; #- default is good enough
if (!$mixed_kind_of_disks && arch() !~ /ia64/) {
setupBootloader__mbr_or_not($in, $b, $hds, $fstab) or return 0;
} else {
general:
setupBootloader__general($in, $b, $all_hds, $fstab, $security) or return 0;
}
setupBootloader__boot_bios_drive($in, $b, $hds) or goto general;
1;
}
sub setupBootloader__boot_bios_drive {
my ($in, $b, $hds) = @_;
bootloader::mixed_kind_of_disks($hds) &&
$b->{boot} =~ /\d$/ && #- on a partition
is_empty_hash_ref($b->{bios}) && #- some bios mapping already there
arch() !~ /ppc/ or return 1;
log::l("mixed_kind_of_disks");
my $hd = $in->ask_from_listf('', N("You decided to install the bootloader on a partition.
This implies you already have a bootloader on the hard drive you boot (eg: System Commander).
On which drive are you booting?"), \&partition_table::description, $hds) or return 0;
log::l("mixed_kind_of_disks chosen $hd->{device}");
$b->{first_hd_device} = "/dev/$hd->{device}";
1;
}
sub setupBootloader__mbr_or_not {
my ($in, $b, $hds, $fstab) = @_;
if (arch() =~ /ppc/) {
if (defined $partition_table::mac::bootstrap_part) {
$b->{boot} = $partition_table::mac::bootstrap_part;
log::l("set bootstrap to $b->{boot}");
} else {
die "no bootstrap partition - yaboot.conf creation failed";
}
} else {
my $floppy = detect_devices::floppy();
my @l = (
[ N("First sector of drive (MBR)") => '/dev/' . $hds->[0]{device} ],
[ N("First sector of the root partition") => '/dev/' . fsedit::get_root($fstab, 'boot')->{device} ],
if_($floppy,
[ N("On Floppy") => "/dev/$floppy" ],
),
[ N("Skip") => '' ],
);
my $default = arch() =~ /sparc/ ? ($b->{use_partition} ? $l[1] : $l[0]) :
find { $_->[1] eq $b->{boot} } @l;
$in->ask_from_({ title => arch() =~ /sparc/ ? N("SILO Installation") : N("LILO/grub Installation"),
messages => N("Where do you want to install the bootloader?"),
interactive_help_id => 'setupBootloaderBeginner',
},
[ { val => \$default, list => \@l, format => sub { $_[0][0] }, type => 'list' } ]);
my $new_boot = $default->[1] or return;
if (arch() =~ /sparc/) {
$b->{use_partition} = $new_boot eq $l[1][1];
} else {
#- remove bios mapping if the user changed the boot device
delete $b->{bios} if $new_boot ne $b->{boot};
$b->{boot} = $new_boot;
}
}
1;
}
sub setupBootloader__general {
my ($in, $b, $all_hds, $fstab, $security) = @_;
my @silo_install_lang = (N("First sector of drive (MBR)"), N("First sector of boot partition"));
($b->{method}, my $method_choices) = bootloader::method_choices($fstab, $b);
my $profiles = bootloader::has_profiles($b);
my $prev_force_acpi = my $force_acpi = bootloader::get_append($b, 'acpi') !~ /off|ht/;
my $prev_force_noapic = my $force_noapic = bootloader::get_append($b, 'noapic');
my $prev_force_nolapic = my $force_nolapic = bootloader::get_append($b, 'nolapic');
my $memsize = bootloader::get_append($b, 'mem');
my $prev_clean_tmp = my $clean_tmp = any { $_->{mntpoint} eq '/tmp' } @{$all_hds->{special} ||= []};
my $prev_boot = $b->{boot};
$b->{password2} ||= $b->{password} ||= '';
$::Wizard_title = N("Boot Style Configuration");
if (arch() !~ /ppc/) {
$in->ask_from_({ messages => N("Bootloader main options"),
interactive_help_id => 'setupBootloader',
callbacks => {
complete => sub {
!$memsize || $memsize =~ /^\d+K$/ || $memsize =~ s/^(\d+)M?$/$1M/i or $in->ask_warn('', N("Give the ram size in MB")), return 1;
#- $security > 4 && length($b->{password}) < 6 and $in->ask_warn('', N("At this level of security, a password (and a good one) in lilo is requested")), return 1;
$b->{restricted} && !$b->{password} and $in->ask_warn('', N("Option ``Restrict command line options'' is of no use without a password")), return 1;
$b->{password} eq $b->{password2} or !$b->{restricted} or $in->ask_warn('', [ N("The passwords do not match"), N("Please try again") ]), return 1;
0;
},
},
}, [
{ label => N("Bootloader to use"), val => \$b->{method}, list => [ keys %$method_choices ], format => sub { $method_choices->{$_[0]} } },
arch() =~ /sparc/ ? (
{ label => N("Bootloader installation"), val => \$b->{use_partition}, list => [ 0, 1 ], format => sub { $silo_install_lang[$_[0]] } },
) : if_(arch() !~ /ia64/,
{ label => N("Boot device"), val => \$b->{boot}, list => [ map { "/dev/$_" } (map { $_->{device} } (@{$all_hds->{hds}}, grep { !isFat_or_NTFS($_) } @$fstab)), detect_devices::floppies_dev() ], not_edit => !$::expert },
),
{ label => N("Delay before booting default image"), val => \$b->{timeout} },
{ text => N("Enable ACPI"), val => \$force_acpi, type => 'bool' },
if_(!$force_nolapic,
{ text => N("Force no APIC"), val => \$force_noapic, type => 'bool' },
),
{ text => N("Force No Local APIC"), val => \$force_nolapic, type => 'bool' },
if_($security >= 4 || $b->{password} || $b->{restricted},
{ label => N("Password"), val => \$b->{password}, hidden => 1 },
{ label => N("Password (again)"), val => \$b->{password2}, hidden => 1 },
{ text => N("Restrict command line options"), val => \$b->{restricted}, type => "bool", text => N("restrict") },
),
{ text => N("Clean /tmp at each boot"), val => \$clean_tmp, type => 'bool', advanced => 1 },
{ label => N("Precise RAM size if needed (found %d MB)", availableRamMB()), val => \$memsize, advanced => 1 },
if_(detect_devices::isLaptop(),
{ text => N("Enable multiple profiles"), val => \$profiles, type => 'bool', advanced => 1 },
),
]) or return 0;
} else {
$b->{boot} = $partition_table::mac::bootstrap_part;
$in->ask_from_({ messages => N("Bootloader main options"),
interactive_help_id => 'setupYabootGeneral',
}, [
{ label => N("Bootloader to use"), val => \$b->{method}, list => [ keys %$method_choices ], format => sub { $method_choices->{$_[0]} } },
{ label => N("Init Message"), val => \$b->{'init-message'} },
{ label => N("Boot device"), val => \$b->{boot}, list => [ map { "/dev/$_" } (map { $_->{device} } (grep { isAppleBootstrap($_) } @$fstab)) ], not_edit => !$::expert },
{ label => N("Open Firmware Delay"), val => \$b->{delay} },
{ label => N("Kernel Boot Timeout"), val => \$b->{timeout} },
{ label => N("Enable CD Boot?"), val => \$b->{enablecdboot}, type => "bool" },
{ label => N("Enable OF Boot?"), val => \$b->{enableofboot}, type => "bool" },
{ label => N("Default OS?"), val => \$b->{defaultos}, list => [ 'linux', 'macos', 'macosx', 'darwin' ] },
]) or return 0;
}
#- remove bios mapping if the user changed the boot device
delete $b->{bios} if $b->{boot} ne $prev_boot;
if ($b->{method} eq 'grub') {
$in->do_pkgs->ensure_is_installed('grub', "/usr/sbin/grub", 1) or return 0;
}
bootloader::set_profiles($b, $profiles);
bootloader::set_append($b, "mem", $memsize || 0);
if ($prev_force_acpi != $force_acpi) {
bootloader::set_append($b, acpi => ($force_acpi ? '' : 'ht'));
}
if ($prev_force_noapic != $force_noapic) {
($force_noapic ? \&bootloader::set_append : \&bootloader::remove_append_simple)->($b, 'noapic');
}
if ($prev_force_nolapic != $force_nolapic) {
($force_nolapic ? \&bootloader::set_append : \&bootloader::remove_append_simple)->($b, 'nolapic');
}
if ($prev_clean_tmp != $clean_tmp) {
if ($clean_tmp && !fsedit::has_mntpoint('/tmp', $all_hds)) {
push @{$all_hds->{special}}, { device => 'none', mntpoint => '/tmp', type => 'tmpfs' };
} else {
@{$all_hds->{special}} = grep { $_->{mntpoint} ne '/tmp' } @{$all_hds->{special}};
}
}
1;
}
sub setupBootloader__entries {
my ($in, $b, $_all_hds, $fstab) = @_;
my $Modify = sub {
my ($e) = @_;
my $default = my $old_default = $e->{label} eq $b->{default};
my $vga = $e->{vga} || 'normal';
my @l;
if ($e->{type} eq "image") {
@l = (
{ label => N("Image"), val => \$e->{kernel_or_dev}, list => [ map { s/$::prefix//; $_ } glob_("$::prefix/boot/vmlinuz*") ], not_edit => 0 },
{ label => N("Root"), val => \$e->{root}, list => [ map { "/dev/$_->{device}" } @$fstab ], not_edit => !$::expert },
{ label => N("Append"), val => \$e->{append} },
if_(arch() !~ /ppc|ia64/,
{ label => N("Video mode"), val => \$vga, list => [ keys %bootloader::vga_modes ], format => sub { $bootloader::vga_modes{$_[0]} }, not_edit => !$::expert, advanced => 1 },
),
{ label => N("Initrd"), val => \$e->{initrd}, list => [ map { s/$::prefix//; $_ } glob_("$::prefix/boot/initrd*") ], not_edit => 0, advanced => 1 },
);
} else {
@l = (
{ label => N("Root"), val => \$e->{kernel_or_dev}, list => [ map { "/dev/$_->{device}" } @$fstab, detect_devices::floppies() ], not_edit => !$::expert },
);
}
if (arch() !~ /ppc/) {
@l = (
{ label => N("Label"), val => \$e->{label} },
@l,
{ text => N("Default"), val => \$default, type => 'bool' },
);
} else {
unshift @l, { label => N("Label"), val => \$e->{label}, list => ['macos', 'macosx', 'darwin'] };
if ($e->{type} eq "image") {
@l = ({ label => N("Label"), val => \$e->{label} },
$::expert ? @l[1..4] : (@l[1..2], { label => N("Append"), val => \$e->{append} }),
if_($::expert, { label => N("Initrd-size"), val => \$e->{initrdsize}, list => [ '', '4096', '8192', '16384', '24576' ] }),
if_($::expert, $l[5]),
{ label => N("NoVideo"), val => \$e->{novideo}, type => 'bool' },
{ text => N("Default"), val => \$default, type => 'bool' }
);
}
}
$in->ask_from_(
{
interactive_help_id => arch() =~ /ppc/ ? 'setupYabootAddEntry' : 'setupBootloaderAddEntry',
callbacks => {
complete => sub {
$e->{label} or $in->ask_warn('', N("Empty label not allowed")), return 1;
$e->{kernel_or_dev} or $in->ask_warn('', $e->{type} eq 'image' ? N("You must specify a kernel image") : N("You must specify a root partition")), return 1;
member(lc $e->{label}, map { lc $_->{label} } grep { $_ != $e } @{$b->{entries}}) and $in->ask_warn('', N("This label is already used")), return 1;
0;
} } }, \@l) or return;
$b->{default} = $old_default || $default ? $default && $e->{label} : $b->{default};
$e->{vga} = $vga eq 'normal' ? '' : $vga;
bootloader::configure_entry($e); #- hack to make sure initrd file are built.
1;
};
my $Add = sub {
my @labels = map { $_->{label} } @{$b->{entries}};
my ($e, $prefix);
if ($in->ask_from_list_('', N("Which type of entry do you want to add?"),
[ N_("Linux"), arch() =~ /sparc/ ? N_("Other OS (SunOS...)") : arch() =~ /ppc/ ?
N_("Other OS (MacOS...)") : N_("Other OS (windows...)") ]
) eq "Linux") {
$e = { type => 'image',
root => '/dev/' . fsedit::get_root($fstab)->{device}, #- assume a good default.
};
$prefix = "linux";
} else {
$e = { type => 'other' };
$prefix = arch() =~ /sparc/ ? "sunos" : arch() =~ /ppc/ ? "macos" : "windows";
}
$e->{label} = $prefix;
for (my $nb = 0; member($e->{label}, @labels); $nb++) {
$e->{label} = "$prefix-$nb";
}
$Modify->($e) or return;
bootloader::add_entry($b, $e);
$e;
};
my $Remove = sub {
my ($e) = @_;
delete $b->{default} if $b->{default} eq $e->{label};
@{$b->{entries}} = grep { $_ != $e } @{$b->{entries}};
1;
};
my @prev_entries = @{$b->{entries}};
if ($in->ask_from__add_modify_remove('',
N("Here are the entries on your boot menu so far.
You can create additional entries or change the existing ones."), [ {
format => sub {
my ($e) = @_;
ref($e) ?
"$e->{label} ($e->{kernel_or_dev})" . ($b->{default} eq $e->{label} && " *") :
translate($e);
}, list => $b->{entries},
} ], Add => $Add, Modify => $Modify, Remove => $Remove)) {
1;
} else {
@{$b->{entries}} = @prev_entries;
'';
}
}
my @etc_pass_fields = qw(name pw uid gid realname home shell);
sub unpack_passwd {
my ($l) = @_;
my %l; @l{@etc_pass_fields} = split ':', chomp_($l);
\%l;
}
sub pack_passwd {
my ($l) = @_;
join(':', @$l{@etc_pass_fields}) . "\n";
}
sub get_autologin() {
my %desktop = getVarsFromSh("$::prefix/etc/sysconfig/desktop");
my $desktop = $desktop{DESKTOP} || 'KDE';
my $autologin = do {
if (($desktop{DISPLAYMANAGER} || $desktop) eq 'GNOME') {
my %conf = read_gnomekderc("$::prefix/etc/X11/gdm/gdm.conf", 'daemon');
text2bool($conf{AutomaticLoginEnable}) && $conf{AutomaticLogin};
} else { # KDM / MdkKDM
my %conf = read_gnomekderc("$::prefix/usr/share/config/kdm/kdmrc", 'X-:0-Core');
text2bool($conf{AutoLoginEnable}) && $conf{AutoLoginUser};
}
};
{ autologin => $autologin, desktop => $desktop };
}
sub set_autologin {
my ($user, $desktop) = @_;
my $autologin = bool2text($user);
#- Configure KDM / MDKKDM
eval { update_gnomekderc("$::prefix/usr/share/config/kdm/kdmrc", 'X-:0-Core' => (
AutoLoginEnable => $autologin,
AutoLoginUser => $user,
)) };
#- Configure GDM
eval { update_gnomekderc("$::prefix/etc/X11/gdm/gdm.conf", daemon => (
AutomaticLoginEnable => $autologin,
AutomaticLogin => $user,
)) };
if ($user) {
my %l = getVarsFromSh("$::prefix/etc/sysconfig/desktop");
$l{DESKTOP} = $desktop;
setVarsInSh("$::prefix/etc/sysconfig/desktop", \%l);
log::l("cat $::prefix/etc/sysconfig/desktop ($desktop):\n", cat_("$::prefix/etc/sysconfig/desktop"));
}
my $xdm_autologin_cfg = "$::prefix/etc/sysconfig/autologin";
if (member($desktop, 'KDE', 'GNOME')) {
unlink $xdm_autologin_cfg;
} else {
setVarsInShMode($xdm_autologin_cfg, 0644,
{ USER => $user, AUTOLOGIN => bool2yesno($user), EXEC => '/usr/X11R6/bin/startx.autologin' });
}
}
sub rotate_log {
my ($f) = @_;
if (-e $f) {
my $i = 1;
for (; -e "$f$i" || -e "$f$i.gz"; $i++) {}
rename $f, "$f$i";
}
}
sub rotate_logs {
my ($prefix) = @_;
rotate_log("$prefix/root/drakx/$_") foreach qw(ddebug.log install.log);
}
sub writeandclean_ldsoconf {
my ($prefix) = @_;
my $file = "$prefix/etc/ld.so.conf";
my @l = chomp_(cat_($file));
@l = grep { !m|^(/usr)?/lib(64)?$| } @l; #- no need to have /lib and /usr/lib in ld.so.conf
push @l, '/usr/X11R6/lib', if_(arch() =~ /x86_64/, '/usr/X11R6/lib64');
push @l, grep { -d "$::prefix$_" } '/usr/lib/qt3/lib', if_(arch() =~ /x86_64/, '/usr/lib/qt3/lib64'); #- needed for upgrade where package renaming can cause this to disappear
output($file, map { "$_\n" } uniq(@l));
}
sub shells() {
grep { -x "$::prefix$_" } chomp_(cat_("$::prefix/etc/shells"));
}
sub inspect {
my ($part, $o_prefix, $b_rw) = @_;
isMountableRW($part) or return;
my $dir = $::isInstall ? "/tmp/inspect_tmp_dir" : "/root/.inspect_tmp_dir";
if ($part->{isMounted}) {
$dir = ($o_prefix || '') . $part->{mntpoint};
} elsif ($part->{notFormatted} && !$part->{isFormatted}) {
$dir = '';
} else {
mkdir $dir, 0700;
eval { fs::mount($part->{device}, $dir, type2fs($part, 'skip'), !$b_rw) };
$@ and return;
}
my $h = before_leaving {
if (!$part->{isMounted} && $dir) {
fs::umount($dir);
unlink($dir)
}
};
$h->{dir} = $dir;
$h;
}
sub ask_user_one {
my ($in, $users, $security, %options) = @_;
my @icons = facesnames();
my %high_security_groups = (
xgrp => N("access to X programs"),
rpm => N("access to rpm tools"),
wheel => N("allow \"su\""),
adm => N("access to administrative files"),
ntools => N("access to network tools"),
ctools => N("access to compilation tools"),
);
my $u;
$u->{password2} ||= $u->{password} ||= '';
$u->{shell} ||= '/bin/bash';
my $names = @$users ? N("(already added %s)", join(", ", map { $_->{realname} || $_->{name} } @$users)) : '';
my %groups;
my $verif = sub {
$u->{password} eq $u->{password2} or $in->ask_warn('', [ N("The passwords do not match"), N("Please try again") ]), return 1,2;
$security > 3 && length($u->{password}) < 6 and $in->ask_warn('', N("This password is too simple")), return 1,2;
$u->{name} or $in->ask_warn('', N("Please give a user name")), return 1,0;
$u->{name} =~ /^[a-z]+?[a-z0-9_-]*?$/ or $in->ask_warn('', N("The user name must contain only lower cased letters, numbers, `-' and `_'")), return 1,0;
length($u->{name}) <= 32 or $in->ask_warn('', N("The user name is too long")), return 1,0;
member($u->{name}, 'root', map { $_->{name} } @$users) and $in->ask_warn('', N("This user name has already been added")), return 1,0;
return 0;
};
my $ret = $in->ask_from_(
{ title => N("Add user"),
messages => N("Enter a user\n%s", $options{additional_msg} || $names),
interactive_help_id => 'addUser',
focus_first => 1,
if_(!$::isInstall, ok => N("Done")),
cancel => $options{noaccept} ? '' : N("Accept user"),
callbacks => {
focus_out => sub {
if ($_[0] eq '0') {
$u->{name} ||= lc first($u->{realname} =~ /([\w-]+)/);
}
},
complete => sub { $u->{name} ? &$verif : 0 },
canceled => $verif,
ok_disabled => sub { $security >= 4 && !@$users || $options{needauser} && !$u->{name} },
} }, [
{ label => N("Real name"), val => \$u->{realname} },
{ label => N("User name"), val => \$u->{name} },
{ label => N("Password"),val => \$u->{password}, hidden => 1 },
{ label => N("Password (again)"), val => \$u->{password2}, hidden => 1 },
{ label => N("Shell"), val => \$u->{shell}, list => [ shells() ], not_edit => !$::expert, advanced => 1 },
if_($security <= 3 && !$options{noicons} && @icons,
{ label => N("Icon"), val => \ ($u->{icon} ||= 'default'), list => \@icons, icon2f => \&face2png, format => \&translate },
),
if_($security > 3,
map {
{ label => $_, val => \$groups{$_}, text => $high_security_groups{$_}, type => 'bool' }
} keys %high_security_groups,
),
],
);
$u->{groups} = [ grep { $groups{$_} } keys %groups ];
push @$users, $u if $u->{name};
return $ret;
}
sub ask_users {
my ($in, $users, $security) = @_;
while (1) {
ask_user_one($in, $users, $security) and return;
}
}
sub sessions() {
split(' ', run_program::rooted_get_stdout($::prefix, '/usr/sbin/chksession', '-l'));
}
sub autologin {
my ($o, $in) = @_;
my @wm = sessions();
my @users = map { $_->{name} } @{$o->{users} || []};
if (member('KDE', @wm) && @users == 1 && $o->{meta_class} eq 'desktop') {
$o->{desktop} = 'KDE';
$o->{autologin} = $users[0];
} elsif (@wm > 1 && @users && !$o->{authentication}{NIS} && $o->{security} <= 2) {
my $use_autologin = @users == 1;
$in->ask_from_(
{ title => N("Autologin"),
messages => N("I can set up your computer to automatically log on one user.") },
[ { label => N("Do you want to use this feature?"), val => \$use_autologin, type => 'bool' },
{ label => N("Choose the default user:"), val => \$o->{autologin}, list => \@users, disabled => sub { !$use_autologin } },
{ label => N("Choose the window manager to run:"), val => \$o->{desktop}, list => \@wm, disabled => sub { !$use_autologin } } ]
);
delete $o->{autologin} if !$use_autologin;
} else {
delete $o->{autologin};
}
}
sub selectLanguage {
my ($in, $lang, $o_langs_) = @_;
my $common = { messages => N("Please choose a language to use."),
title => 'language choice',
interactive_help_id => 'selectLanguage' };
if ($::isInstall) {
my $langs = $o_langs_ || {};
my $using_images = $in->isa('interactive::gtk') && !$in->{vga16};
#- to create the default value, use the first location for that value :/
$lang = if_(!$::move, first(lang::l2location($lang)).'|').$lang;
my %name2l = map { lang::l2name($_) => $_ } lang::list_langs();
my $listval2val = sub { $_[0] =~ /\|(.*)/ ? $1 : $_[0] };
my @langs = map { my $l = $_; uniq_ { $_->[0] } map { [ $::move ? $l : "$_|$l", $_, $l ] } lang::l2location($l) } lang::list_langs();
#- since gtk version will use images (function image2f) we need to sort differently
my $sort_func = $using_images ? \&lang::l2transliterated : \&lang::l2name;
@langs = map { $_->[0] } sort { $sort_func->($a->[2]) cmp $sort_func->($b->[2]) } @langs;
my $last_utf8 = $in->{locale}{utf8};
add2hash($common, { cancel => '',
advanced_messages => formatAlaTeX(N("Mandrakelinux can support multiple languages. Select
the languages you would like to install. They will be available
when your installation is complete and you restart your system.")),
callbacks => { advanced => sub { $langs->{$listval2val->($lang)} = 1 },
changed => sub {
if ($last_utf8 == $in->{locale}{utf8}) {
$last_utf8 = $in->{locale}{utf8} = lang::utf8_should_be_needed({ lang => $listval2val->($lang), langs => $langs });
} else {
$last_utf8 = -1; #- disable auto utf8 once touched
}
} } });
$in->ask_from_($common,
[ { val => \$lang, separator => '|',
if_($using_images, image2f => sub { $name2l{$_[0]} =~ /^[a-z]/ ? ('', "langs/lang-$name2l{$_[0]}") : $_[0] }),
format => sub { $_[0] =~ /(.*\|)(.*)/ ? $1.lang::l2name($2) : lang::l2name($_[0]) },
list => \@langs, sort => 0 },
if_($o_langs_ && !$::move,
{ val => \$in->{locale}{utf8}, type => 'bool', text => N("Use Unicode by default"), advanced => 1 },
{ val => \$langs->{all}, type => 'bool', text => N("All languages"), advanced => 1 },
map {
{ val => \$langs->{$_->[0]}, type => 'bool', disabled => sub { $langs->{all} },
text => $_->[1], advanced => 1,
image => "langs/lang-$_->[0]",
}
} sort { $a->[1] cmp $b->[1] } map { [ $_, $sort_func->($_) ] } lang::list_langs())
]) or return;
$langs->{$listval2val->($lang)} = 1;
$langs->{$_} or delete $langs->{$_} foreach keys %$langs; #- clean hash
#- convert to the default locale for asked language
$listval2val->($lang);
} else {
my @langs = sort { lang::l2name($a) cmp lang::l2name($b) } lang::list_langs(exclude_non_installed => 1);
die 'one lang only' if @langs == 1;
$in->ask_from_($common,
[ { val => \$lang, type => 'list',
format => sub { lang::l2name($_[0]) }, list => \@langs } ]) or return;
$lang;
}
}
sub selectCountry {
my ($o, $locale) = @_;
my $country = $locale->{country};
my @countries = lang::list_countries(exclude_non_installed => !$::isInstall);
my @best = uniq map { if_((/^\Q$locale->{lang}/ || substr($_, 0, 2) eq substr($locale->{lang}, 0, 2))
&& /.._(..)/, $1) } @lang::locales;
@best == 1 and @best = ();
my ($other, $ext_country);
member($country, @best) or ($ext_country, $country) = ($country, $ext_country);
$o->ask_from_(
{ title => N("Country / Region"),
messages => N("Please choose your country."),
interactive_help_id => 'selectCountry',
advanced_messages => N("Here is the full list of available countries"),
advanced_label => N("More"),
advanced_state => $ext_country && scalar(@best),
callbacks => { changed => sub { $other = $_[0] == 1 } },
},
[ if_(@best, { val => \$country, type => 'list', format => \&lang::c2name,
list => \@best, sort => 1 }),
{ val => \$ext_country, type => 'list', format => \&lang::c2name,
list => [ difference2(\@countries, \@best) ], advanced => scalar(@best) }
]) or return;
$locale->{country} = $other || !@best ? $ext_country : $country;
}
sub write_passwd_user {
my ($u, $isMD5) = @_;
$u->{pw} = $u->{password} ? &crypt($u->{password}, $isMD5) : $u->{pw} || '';
$u->{shell} ||= '/bin/bash';
substInFile {
my $l = unpack_passwd($_);
if ($l->{name} eq $u->{name}) {
add2hash_($u, $l);
$_ = pack_passwd($u);
$u = {};
}
if (eof && $u->{name}) {
$_ .= pack_passwd($u);
}
} "$::prefix/etc/passwd";
}
sub set_login_serial_console {
my ($port, $speed) = @_;
my $line = "s$port:12345:respawn:/sbin/getty ttyS$port DT$speed ansi\n";
substInFile { s/^s$port:.*//; $_ = $line if eof } "$::prefix/etc/inittab";
}
sub report_bug {
my ($prefix, @other) = @_;
sub header { "
********************************************************************************
* $_[0]
********************************************************************************";
}
join '', map { chomp; "$_\n" }
header("lspci"), detect_devices::stringlist(),
header("pci_devices"), cat_("/proc/bus/pci/devices"),
header("dmidecode"), `$ENV{LD_LOADER} dmidecode`,
header("fdisk"), arch() =~ /ppc/ ? `$ENV{LD_LOADER} pdisk -l` : `$ENV{LD_LOADER} fdisk -l`,
header("scsi"), cat_("/proc/scsi/scsi"),
header("lsmod"), cat_("/proc/modules"),
header("cmdline"), cat_("/proc/cmdline"),
header("pcmcia: stab"), cat_("$prefix/var/lib/pcmcia/stab") || cat_("$prefix/var/run/stab"),
header("usb"), cat_("/proc/bus/usb/devices"),
header("partitions"), cat_("/proc/partitions"),
header("cpuinfo"), cat_("/proc/cpuinfo"),
header("syslog"), cat_("/tmp/syslog") || cat_("$prefix/var/log/syslog"),
header("ddcxinfos"), ddcxinfos(),
header("stage1.log"), cat_("/tmp/stage1.log") || cat_("$prefix/root/drakx/stage1.log"),
header("ddebug.log"), cat_("/tmp/ddebug.log") || cat_("$prefix/root/drakx/ddebug.log"),
header("install.log"), cat_("$prefix/root/drakx/install.log"),
header("fstab"), cat_("$prefix/etc/fstab"),
header("modules.conf"), cat_("$prefix/etc/modules.conf"),
header("lilo.conf"), cat_("$prefix/etc/lilo.conf"),
header("menu.lst"), cat_("$prefix/boot/grub/menu.lst"),
header("XF86Config"), cat_("$prefix/etc/X11/XF86Config"),
header("XF86Config-4"), cat_("$prefix/etc/X11/XF86Config-4"),
header("/etc/modules"), cat_("$prefix/etc/modules"),
header("sysconfig/i18n"), cat_("$prefix/etc/sysconfig/i18n"),
map_index { even($::i) ? header($_) : $_ } @other;
}
sub devfssymlinkf {
my ($if_struct, $of) = @_;
my $if = $if_struct->{device};
my $devfs_if = $if_struct->{devfs_device};
$devfs_if ||= devices::to_devfs($if);
$devfs_if ||= $if;
#- example: $of is mouse, $if is usbmouse, $devfs_if is input/mouse0
output_p("$::prefix/etc/devfs/conf.d/$of.conf",
"REGISTER ^$devfs_if\$ CFUNCTION GLOBAL mksymlink $devfs_if $of
UNREGISTER ^$devfs_if\$ CFUNCTION GLOBAL unlink $of
");
output_p("$::prefix/etc/devfs/conf.d/$if.conf",
"REGISTER ^$devfs_if\$ CFUNCTION GLOBAL mksymlink $devfs_if $if
UNREGISTER ^$devfs_if\$ CFUNCTION GLOBAL unlink $if
") if $devfs_if ne $if && $if !~ /^hd[a-z]/ && $if !~ /^sr/ && $if !~ /^sd[a-z]/;
#- when creating a symlink on the system, use devfs name if devfs is mounted
symlinkf($devfs_if, "$::prefix/dev/$if") if $devfs_if ne $if && detect_devices::dev_is_devfs();
symlinkf($if, "$::prefix/dev/$of");
}
sub devfs_rawdevice {
my ($if_struct, $of) = @_;
my $devfs_if = $if_struct->{devfs_device};
$devfs_if ||= devices::to_devfs($if_struct->{device});
$devfs_if ||= $if_struct->{device};
output_p("$::prefix/etc/devfs/conf.d/$of.conf",
"REGISTER ^$devfs_if\$ EXECUTE /etc/dynamic/scripts/rawdevice.script add /dev/$devfs_if /dev/$of
UNREGISTER ^$devfs_if\$ EXECUTE /etc/dynamic/scripts/rawdevice.script del /dev/$of
");
}
sub fix_broken_alternatives() {
#- fix bad update-alternatives that may occurs after upgrade (and sometimes for install too).
-d "$::prefix/etc/alternatives" or return;
foreach (all("$::prefix/etc/alternatives")) {
next if run_program::rooted($::prefix, 'test', '-e', "/etc/alternatives/$_");
log::l("fixing broken alternative $_");
run_program::rooted($::prefix, 'update-alternatives', '--auto', $_);
}
}
sub fileshare_config {
my ($in, $type) = @_; #- $type is 'nfs', 'smb' or ''
my $file = '/etc/security/fileshare.conf';
my %conf = getVarsFromSh($file);
my @l = (N_("No sharing"), N_("Allow all users"), N_("Custom"));
my $restrict = exists $conf{RESTRICT} ? text2bool($conf{RESTRICT}) : 1;
my $r = $in->ask_from_list_('fileshare',
N("Would you like to allow users to share some of their directories?
Allowing this will permit users to simply click on \"Share\" in konqueror and nautilus.
\"Custom\" permit a per-user granularity.
"),
\@l, $l[$restrict ? 0 : 1]) or return;
$restrict = $r ne $l[1];
my $custom = $r eq $l[2];
if ($r ne $l[0]) {
#- verify we can export in $type
my %type2file = (nfs => [ 'nfs-utils', '/etc/init.d/nfs' ], smb => [ 'samba-server', '/etc/init.d/smb' ]);
my %l;
if ($type) {
%l = ($type => 1);
} else {
%l = map_each { $::a => -e $::b->[1] } %type2file;
$in->ask_from('', N("You can export using NFS or Samba. Please select which you'd like to use."),
[ map { { text => $_, val => \$l{$_}, type => 'bool' } } keys %l ]) or return;
}
foreach (keys %l) {
my ($pkg, $file) = @{$type2file{$_}} or die "unknown type $_\n";
if ($l{$_}) {
$in->do_pkgs->ensure_is_installed($pkg, $file) or return;
} elsif (-e $file) {
$in->ask_okcancel('', N("The package %s is going to be removed.", $pkg), 1) or return;
$in->do_pkgs->remove($pkg);
}
}
}
$conf{RESTRICT} = bool2yesno($restrict);
setVarsInSh($file, \%conf);
if ($custom) {
run_program::rooted($::prefix, 'groupadd', '-r', 'fileshare');
if ($in->ask_from_no_check(
{
-e '/usr/sbin/userdrake' ? (ok => N("Launch userdrake"), cancel => N("Cancel")) : (cancel => ''),
messages =>
N("The per-user sharing uses the group \"fileshare\".
You can use userdrake to add a user to this group.")
}, [])) {
run_program::run('userdrake');
}
}
}
sub ddcxinfos() {
return if $::noauto;
my @l;
run_program::raw({ timeout => 20 }, 'ddcxinfos', '>', \@l);
if ($::isInstall && -e "/tmp/ddcxinfos") {
my @l_old = cat_("/tmp/ddcxinfos");
if (@l < @l_old) {
log::l("new ddcxinfos is worse, keeping the previous one");
@l = @l_old;
} elsif (@l > @l_old) {
log::l("new ddcxinfos is better, dropping the previous one");
}
}
output("/tmp/ddcxinfos", @l) if $::isInstall;
@l;
}
sub running_window_manager() {
my @window_managers = qw(kwin gnome-session icewm wmaker afterstep fvwm fvwm2 fvwm95 mwm twm enlightenment xfce blackbox sawfish olvwm);
foreach (@window_managers) {
my @pids = fuzzy_pidofs(qr/\b$_\b/) or next;
return wantarray() ? ($_, @pids) : $_;
}
undef;
}
sub ask_window_manager_to_logout {
my ($wm) = @_;
my %h = (
'kwin' => "dcop kdesktop default logout",
'gnome-session' => "gnome-session-save --kill",
'icewm' => "killall -QUIT icewm",
'wmaker' => "killall -USR1 wmaker",
);
my $cmd = $h{$wm} or return;
$ENV{ICEAUTHORITY} ||= "$ENV{HOME}/.ICEauthority"; #- used by gnome-session
$cmd = "su $ENV{USER} -c '$cmd'" if $wm eq 'kwin' && $> == 0;
system($cmd);
1;
}
sub alloc_raw_device {
my ($prefix, $device) = @_;
my $used = 0;
my $raw_dev;
substInFile {
$used = max($used, $1) if m|^\s*/dev/raw/raw(\d+)|;
if (eof) {
$raw_dev = "raw/raw" . ($used + 1);
$_ .= "/dev/$raw_dev /dev/$device\n";
}
} "$prefix/etc/sysconfig/rawdevices";
$raw_dev;
}
sub config_dvd {
my ($prefix, $have_devfsd) = @_;
#- can't have both a devfs and a non-devfs config
#- the /etc/sysconfig/rawdevices solution gives errors with devfs
my @dvds = grep { detect_devices::isDvdDrive($_) } detect_devices::cdroms() or return;
log::l("configuring DVD: " . join(" ", map { $_->{device} } @dvds));
#- create /dev/dvd symlink
each_index {
devfssymlinkf($_, 'dvd' . ($::i ? $::i + 1 : ''));
devfs_rawdevice($_, 'rdvd' . ($::i ? $::i + 1 : '')) if $have_devfsd;
} @dvds;
if (!$have_devfsd) {
my $raw_dev = alloc_raw_device($prefix, 'dvd');
symlink($raw_dev, "$prefix/dev/rdvd");
}
}
sub config_mtools {
my ($prefix) = @_;
my $file = "$prefix/etc/mtools.conf";
-e $file or return;
my ($f1, $f2) = detect_devices::floppies_dev();
substInFile {
s|drive a: file="(.*?)"|drive a: file="/dev/$f1"|;
s|drive b: file="(.*?)"|drive b: file="/dev/$f2"| if $f2;
} $file;
}
1;
ipl">@EXPORT_OK $border $use_pixbuf $use_imlib);
@ISA = qw(Exporter);
%EXPORT_TAGS = (
helpers => [ qw(createScrolledWindow create_menu create_notebook create_packtable create_hbox create_vbox create_adjustment create_box_with_title create_treeitem create_dialog destroy_window) ],
wrappers => [ qw(gtksignal_connect gtkradio gtkpack gtkpack_ gtkpack__ gtkpack2 gtkpack3 gtkpack2_ gtkpack2__ gtkpowerpack gtkcombo_setpopdown_strings gtkset_editable gtksetstyle gtkset_text gtkset_tip gtkappenditems gtkappend gtkset_shadow_type gtkset_layout gtkset_relief gtkadd gtkexpand gtkput gtktext_insert gtkset_usize gtksize gtkset_justify gtkset_active gtkset_sensitive gtkset_visibility gtkset_modal gtkset_border_width gtkmove gtkresize gtkshow gtkhide gtkdestroy gtkflush gtkcolor gtkset_mousecursor gtkset_mousecursor_normal gtkset_mousecursor_wait gtkset_background gtkset_default_fontset gtkctree_children gtkxpm gtkpng create_pix_text get_text_coord fill_tiled gtkicons_labels_widget write_on_pixmap gtkcreate_xpm gtkcreate_png gtkcreate_png_pixbuf gtkbuttonset create_pixbutton gtkroot gtkentry compose_with_back compose_pixbufs) ],
various => [ qw(add2notebook add_icon_path n_line_size) ],
);
$EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ];
@EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
use Gtk;
if (!$::no_ugtk_init) {
!$ENV{DISPLAY} || system('/usr/X11R6/bin/xtest') and die "Cannot be run in console mode.\n";
Gtk->init;
eval { require Gtk::Gdk::Pixbuf; Gtk::Gdk::Pixbuf->init };
$use_pixbuf = $@ ? 0 : 1;
}
eval { require Gtk::Gdk::ImlibImage; Gtk::Gdk::ImlibImage->init };
$use_imlib = $@ ? 0 : 1;
use c;
use log;
use common;
my @icon_paths;
sub add_icon_path { push @icon_paths, @_ }
sub icon_paths {
(@icon_paths, $ENV{SHARE_PATH}, "$ENV{SHARE_PATH}/icons", "$ENV{SHARE_PATH}/libDrakX/pixmaps", "/usr/lib/libDrakX/icons", "pixmaps", 'standalone/icons');
}
#-#######################
# gtk widgets wrappers
#-#######################
sub gtkdestroy { $_[0] and $_[0]->destroy }
sub gtkflush { Gtk->main_iteration while Gtk->events_pending }
sub gtkhide { $_[0]->hide; $_[0] }
sub gtkmove { $_[0]->window->move($_[1], $_[2]); $_[0] }
sub gtkpack { gtkpowerpack(1, 1, @_) }
sub gtkpack_ { gtkpowerpack('arg', 1, @_) }
sub gtkpack__ { gtkpowerpack(0, 1, @_) }
sub gtkpack2 { gtkpowerpack(1, 0, @_) }
sub gtkpack2_ { gtkpowerpack('arg', 0, @_) }
sub gtkpack2__ { gtkpowerpack(0, 0, @_) }
sub gtkput { $_[0]->put(gtkshow($_[1]), $_[2], $_[3]); $_[0] }
sub gtkpixmap { new Gtk::Pixmap(gdkpixmap(@_)) }
sub gtkresize { $_[0]->window->resize($_[1], $_[2]); $_[0] }
sub gtkset_active { $_[0]->set_active($_[1]); $_[0] }
sub gtkset_border_width { $_[0]->set_border_width($_[1]); $_[0] }
sub gtkset_editable { $_[0]->set_editable($_[1]); $_[0] }
sub gtkset_justify { $_[0]->set_justify($_[1]); $_[0] }
sub gtkset_layout { $_[0]->set_layout($_[1]); $_[0] }
sub gtkset_modal { $_[0]->set_modal($_[1]); $_[0] }
sub gtkset_mousecursor_normal { gtkset_mousecursor(68, @_) }
sub gtkset_mousecursor_wait { gtkset_mousecursor(150, @_) }
sub gtkset_relief { $_[0]->set_relief($_[1]); $_[0] }
sub gtkset_sensitive { $_[0]->set_sensitive($_[1]); $_[0] }
sub gtkset_visibility { $_[0]->set_visibility($_[1]); $_[0] }
sub gtkset_tip { $_[0]->set_tip($_[1], $_[2]) if $_[2]; $_[1] }
sub gtkset_shadow_type { $_[0]->set_shadow_type($_[1]); $_[0] }
sub gtkset_style { $_[0]->set_style($_[1]); $_[0] }
sub gtkset_usize { $_[0]->set_usize($_[1], $_[2]); $_[0] }
sub gtkshow { $_[0]->show; $_[0] }
sub gtksize { $_[0]->size($_[1], $_[2]); $_[0] }
sub gtkexpand { $_[0]->expand; $_[0] }
sub gdkpixmap {
my ($f, $w) = @_;
$f =~ m|.png$| and return gtkcreate_png($f);
$f =~ m|.xpm$| and return gtkcreate_xpm($w, $f);
}
sub gtkadd {
my $w = shift;
foreach (@_) {
my $l = $_;
ref $l or $l = new Gtk::Label($l);
$w->add($l);
$l->show;
}
$w
}
sub gtkappend {
my $w = shift;
foreach (@_) {
my $l = $_;
ref $l or $l = new Gtk::Label($l);
$w->append($l);
$l->show;
}
$w
}
sub gtkappenditems {
my $w = shift;
$_->show() foreach @_;
$w->append_items(@_);
$w
}
sub gtkbuttonset {
gtkdestroy($_[0]->child);
gtkadd($_[0], gtkshow($_[1]))
}
sub create_pixbutton {
my ($label, $pix, $reverse_order) = @_;
gtkadd(new Gtk::Button(), gtkpack_(new Gtk::HBox(0, 3), 1, "", $reverse_order ? (0, $label, if_($pix, 0, $pix)) : (if_($pix, 0, $pix), 0, $label), 1, ""));
}
sub gtkentry {
my ($text) = @_;
my $e = new Gtk::Entry;
$e->set_text($text);
$e;
}
sub gtksetstyle {
my ($w, $s) = @_;
$w->set_style($s);
$w;
}
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 gtkradio {
my $def = shift;
my $radio;
map { $radio = new Gtk::RadioButton($_, if_($radio, $radio));
$radio->set_active($_ eq $def); $radio } @_;
}
sub gtkroot {
Gtk->init;
Gtk->set_locale;
Gtk::Gdk::Window->new_foreign(Gtk::Gdk->ROOT_WINDOW);
}
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 gtktext_insert {
my ($w, $t) = @_;
$w->freeze;
$w->backward_delete($w->get_length);
if (ref($t) eq 'ARRAY') {
$w->insert($_->[0], $_->[1], $_->[2], $_->[3]) foreach @$t;
} else {
$w->insert(undef, undef, undef, $t);
}
#- DEPRECATED? 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 gtkset_text {
my ($w, $s) = @_;
$w->set_text($s);
$w;
}
sub gtkcombo_setpopdown_strings {
my $w = shift;
$w->set_popdown_strings(@_);
$w;
}
sub gtkappend_text {
my ($w, $s) = @_;
$w->append_text($s);
$w;
}
sub gtkprepend_text {
my ($w, $s) = @_;
$w->prepend_text($s);
$w;
}
sub gtkset_mousecursor {
my ($type, $w) = @_;
($w || gtkroot())->set_cursor(Gtk::Gdk::Cursor->new($type));
}
sub gtksignal_connect {
my $w = shift;
$w->signal_connect(@_);
$w;
}
#-#######################
# create widgets wrappers
#-#######################
sub create_adjustment {
my ($val, $min, $max) = @_;
new Gtk::Adjustment($val, $min, $max + 1, 1, ($max - $min + 1) / 10, 1);
}
sub create_box_with_title {
my $o = shift;
my $nbline = sum(map { round(length($_) / 60 + 1/2) } map { split "\n" } @_);
my $box = new Gtk::VBox(0,0);
return $box if $nbline == 0;
$o->{box_size} = n_line_size($nbline, 'text', $box);
if (@_ <= 2 && $nbline > 4) {
$o->{icon} && !$::isWizard and
eval { gtkpack__($box, gtkset_border_width(gtkpack_(new Gtk::HBox(0,0), 1, gtkpng($o->{icon})),5)) };
my $wanted = $o->{box_size};
$o->{box_size} = min(200, $o->{box_size});
my $has_scroll = $o->{box_size} < $wanted;
my $wtext = new Gtk::Text;
$wtext->can_focus($has_scroll);
chomp(my $text = join("\n", @_));
my $scroll = createScrolledWindow(gtktext_insert($wtext, $text));
$scroll->set_usize(400, $o->{box_size});
gtkpack($box, $scroll);
} else {
my $a = !$::no_separator;
undef $::no_separator;
if ($o->{icon} && !$::isWizard) {
gtkpack__($box,
gtkpack_(new Gtk::HBox(0,0),
0, gtkset_usize(new Gtk::VBox(0,0), 15, 0),
0, eval { gtkpng($o->{icon}) },
0, gtkset_usize(new Gtk::VBox(0,0), 15, 0),
1, gtkpack_($o->{box_title} = new Gtk::VBox(0,0),
1, new Gtk::HBox(0,0),
(map {
my $w = ref $_ ? $_ : new Gtk::Label($_);
$::isWizard and $w->set_justify("left");
$w->set_name("Title");
(0, $w);
} map { ref $_ ? $_ : warp_text($_) } @_),
1, new Gtk::HBox(0,0),
)
),
if_($a, new Gtk::HSeparator)
)
} else {
gtkpack__($box,
(map {
my $w = ref $_ ? $_ : new Gtk::Label($_);
$::isWizard and $w->set_justify("left");
$w->set_name("Title");
$w;
} map { ref $_ ? $_ : warp_text($_) } @_),
if_($a, new Gtk::HSeparator)
)
}
}
}
# drakfloppy / logdrake
sub create_dialog {
my ($label, $c) = @_;
my $ret = 0;
my $dialog = new Gtk::Dialog;
$dialog->signal_connect(delete_event => sub { Gtk->main_quit() });
$dialog->set_title(N("logdrake"));
$dialog->border_width(10);
$dialog->vbox->pack_start(new Gtk::Label($label),1,1,0);
my $button = new Gtk::Button(N("OK"));
$button->can_default(1);
$button->signal_connect(clicked => sub { $ret = 1; $dialog->destroy(); Gtk->main_quit() });
$dialog->action_area->pack_start($button, 1, 1, 0);
$button->grab_default;
if ($c) {
my $button2 = new Gtk::Button(N("Cancel"));
$button2->signal_connect(clicked => sub { $ret = 0; $dialog->destroy(); Gtk->main_quit() });
$button2->can_default(1);
$dialog->action_area->pack_start($button2, 1, 1, 0);
}
$dialog->show_all;
Gtk->main();
$ret;
}
# drakfloppy / logdrake
sub destroy_window {
my ($_widget, $windowref, $w2) = @_;
$$windowref = undef;
$w2 = undef if defined $w2;
0;
}
sub create_hbox { gtkset_layout(gtkset_border_width(new Gtk::HButtonBox, 3), $_[0] || 'spread') }
sub create_factory_menu_ {
my ($type, $name, $window, @menu_items) = @_;
my $widget = new Gtk::ItemFactory($type, $name, my $accel_group = new Gtk::AccelGroup);
$widget->create_items(@menu_items);
$window->add_accel_group($accel_group); #$accel_group->attach($main_win);
my $menu = $widget->get_widget($name);
$menu->{factory} = $widget;
$menu; # return menu bar
}
sub create_factory_menu { create_factory_menu_('Gtk::MenuBar', '<main>', @_) }
sub create_menu {
my $title = shift;
my $w = new Gtk::MenuItem($title);
$w->set_submenu(gtkshow(gtkappend(new Gtk::Menu, @_)));
$w
}
sub create_notebook {
my $n = new Gtk::Notebook;
add2notebook($n, splice(@_, 0, 2)) while @_;
$n
}
sub create_packtable {
my ($options, @l) = @_;
my $w = new Gtk::Table(0, 0, $options->{homogeneous} || 0);
each_index {
my ($i, $l) = ($_[0], $_);
each_index {
my ($j) = @_;
if ($_) {
ref $_ or $_ = new Gtk::Label($_);
$j != $#$l ?
$w->attach($_, $j, $j + 1, $i, $i + 1, 'fill', 'fill', 5, 0) :
$w->attach($_, $j, $j + 1, $i, $i + 1, 1|4, ref($_) eq 'Gtk::ScrolledWindow' ? 1|4 : 0, 0, 0);
$_->show;
}
} @$l;
} @l;
$w->set_col_spacings($options->{col_spacings} || 0);
$w->set_row_spacings($options->{row_spacings} || 0);
$w
}
sub createScrolledWindow {
my ($W, $policy, $viewport_shadow) = @_;
my $w = new Gtk::ScrolledWindow(undef, undef);
$policy ||= [ 'automatic', 'automatic' ];
$w->set_policy(@{$policy});
if (member(ref $W, qw(Gtk::CList Gtk::CTree Gtk::Text))) {
$w->add($W)
} else {
$w->add_with_viewport($W);
$viewport_shadow and gtkset_shadow_type($w->child, $viewport_shadow);
}
$W->can("set_focus_vadjustment") and $W->set_focus_vadjustment($w->get_vadjustment);
$W->show;
$w
}
sub create_treeitem {
my ($name) = @_;
my ($next_child, $left, $right, $up, $down);
$next_child = sub {
my ($c, $dir) = @_;
my @childs = $c->parent->children;
my $i; for ($i = 0; $i < @childs; $i++) { last if $childs[$i] == $c || $childs[$i]->subtree == $c }
$i += $dir;
0 <= $i && $i < @childs ? $childs[$i] : undef;
};
$left = sub { &$next_child($_[0]->parent, 0) };
$right = sub { my ($c) = @_; $c->subtree and $c->expand, return ($c->subtree->children)[0]; $c };
$down = sub {
my ($c) = @_;
return &$right($c) if ref $c eq "Gtk::TreeItem" && $c->subtree && $c->expanded;
if (my $n = &$next_child($c, 1)) {
$n;
} else {
return if ref $c->parent ne 'Gtk::Tree';
&$down($c->parent);
}
};
$up = sub {
my ($c) = @_;
if (my $n = &$next_child($c, -1)) {
$n = ($n->subtree->children)[-1] while ref $n eq "Gtk::TreeItem" && $n->subtree && $n->expanded;
$n;
} else {
return if ref $c->parent ne 'Gtk::Tree';
&$left($c);
}
};
my $w = new Gtk::TreeItem($name);
$w->signal_connect(key_press_event => sub {
my (undef, $e) = @_;
local $_ = chr $e->{keyval};
if ($e->{keyval} > 0x100) {
my $n;
$n = &$left($w) if /[Q\xb4\x96]/;
$n = &$right($w) if /[S\xb6\x98]/;
$n = &$up($w) if /[R\xb8\x97]/;
$n = &$down($w) if /[T\xb2\x99]/;
if ($n) {
$n->focus('up');
$w->signal_emit_stop("key_press_event");
}
$w->expand if /[+\xab]/;
$w->collapse if /[-\xad]/;
do {
$w->expanded ? $w->collapse : $w->expand;
$w->signal_emit_stop("key_press_event");
} if /[\r\x8d]/;
}
1;
});
$w;
}
sub create_vbox { gtkset_layout(new Gtk::VButtonBox, $_[0] || 'spread') }
#-#######################
# public gtk routines
#-#######################
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 tree_set_icon {
my ($node, $label, $icon) = @_;
my $hbox = new Gtk::HBox(0,0);
gtkpack__(1, $hbox, gtkshow(gtkpng($icon)), gtkshow(new Gtk::Label($label)));
gtkadd($node, gtkshow($hbox));
}
sub ctree_set_icon {
my ($tree, $node, $icon_pixmap, $icon_mask) = @_;
my ($text, $spacing, undef, undef, undef, undef, $isleaf, $expanded) = $tree->get_node_info($node);
$tree->set_node_info($node, $text, $spacing, $icon_pixmap, $icon_mask, $icon_pixmap, $icon_mask, $isleaf, $expanded);
}
sub get_text_coord {
my ($text, $widget4style, $max_width, $max_height, $can_be_greater, $can_be_smaller, $centeredx, $centeredy, $wrap_char) = @_;
$wrap_char ||= ' ';
my $idx = 0;
my $real_width = 0;
my $real_height = 0;
my @lines;
my @widths;
my @heights;
my $height_elem = $widget4style->style->font->ascent + $widget4style->style->font->descent;
$heights[0] = 0;
my $max_width2 = $max_width;
my $height = $heights[0] = $height_elem;
my $width = 0;
my $flag = 1;
my @t = split($wrap_char, $text);
my @t2;
if ($::isInstall && $::o->{lang} =~ /ja|zh/) {
@t = map { $_ . $wrap_char } @t;
$wrap_char = '';
foreach (@t) {
my @c = split('');
my $i = 0;
my $el = '';
while (1) {
$i >= @c and last;
$el .= $c[$i];
if (ord($c[$i]) >= 128) { $el .= $c[$i+1]; $i++; push @t2, $el; $el = '' }
$i++;
}
$el and push @t2, $el;
}
} else {
@t2 = @t;
}
foreach (@t2) {
my $l = $widget4style->style->font->string_width($_ . (!$flag ? $wrap_char : ''));
if ($width + $l > $max_width2 && !$flag) {
$flag = 1;
$height += $height_elem + 1;
$heights[$idx+1] = $height;
$widths[$idx] = $centeredx && !$can_be_smaller ? (max($max_width2-$width, 0))/2 : 0;
$width = 0;
$idx++;
}
$lines[$idx] = $flag ? $_ : $lines[$idx] . $wrap_char . $_;
$width += $l;
$flag = 0;
$l <= $max_width2 or $max_width2 = $l;
$width <= $real_width or $real_width = $width;
}
$height += $height_elem;
$widths[$idx] = $centeredx && !$can_be_smaller ? (max($max_width2-$width, 0))/2 : 0;
$height < $real_height or $real_height = $height;
$width = $max_width;
$height = $max_height;
$real_width < $max_width && $can_be_smaller and $width = $real_width;
$real_width > $max_width && $can_be_greater and $width = $real_width;
$real_height < $max_height && $can_be_smaller and $height = $real_height;
$real_height > $max_height && $can_be_greater and $height = $real_height;
if ($centeredy) {
my $dh = ($height-$real_height)/2 + ($height_elem)/2;
@heights = map { $_ + $dh } @heights;
}
($width, $height, \@lines, \@widths, \@heights)
}
sub gtkicons_labels_widget {
my ($args, $_w, $widget_for_font, $background, $back_pixbuf, $_xback, $_yback, $x_round,
$y_round, $x_back2, $y_back2, $icon_width, $icon_height, $exec_func, $exec_hash) = @_;
my @tab;
my $cursor_hand = new Gtk::Gdk::Cursor(60);
my $cursor_normal = new Gtk::Gdk::Cursor(68);
my @args = @$args;
foreach (@args) {
my ($label, $tag) = ($_->[0], $_->[1]);
die "$label 's icon is missing" unless $exec_hash->{$label};
my ($dbl_area, $pix, $width, $height); # initialized in call back
my $darea = new Gtk::DrawingArea;
my ($icon, undef) = gtkcreate_png($tag);
my $pixbuf = compose_with_back($tag, $back_pixbuf);
my $pixbuf_h = compose_with_back($tag, $back_pixbuf, 170);
my $draw = sub {
my ($_widget, $event) = @_;
my ($dx, $dy) = ($darea->allocation->[2], $darea->allocation->[3]);
my $state = $darea->{state};
if (!defined($dbl_area)) {
($pix, $width, $height) = create_pix_text($darea, $label, $widget_for_font->style->font, $x_round, 1,
1, 0, [$background, $background], $x_back2, $y_back2, 1, 0);
($dx, $dy) = (max($width, $x_round), $y_round + $height);
$darea->set_usize($dx, $dy);
$dbl_area = new Gtk::Gdk::Pixmap($darea->window, max($width, $x_round), $y_round + $height);
}
# Redraw if state change (selected <=> not selected)
if (!$dbl_area->{state} || $state != $dbl_area->{state}) {
$dbl_area->{state} = $state;
fill_tiled($darea, $dbl_area, $background, $x_back2, $y_back2, $dx, $dy);
($state ? $pixbuf_h : $pixbuf)->render_to_drawable($dbl_area, $darea->style->fg_gc('normal'), 0, 0, 0, 0,
$pixbuf->get_width, $pixbuf->get_height, 'normal', 0, 0);
$dbl_area->draw_pixmap($darea->style->bg_gc('normal'), ($state ? $pix->[1] : $pix->[0]),
0, 0, ($dx - $width)/2, $y_round, $width, $height);
}
$darea->window->draw_pixmap($darea->style->bg_gc('normal'), $dbl_area, 0, 0, 0, 0, $dx, $dy);
($darea->{dx}, $darea->{dy}) = ($dx, $dy);
};
$darea->{state} = 0;
$darea->signal_connect(expose_event => $draw);
$darea->set_events([ 'exposure_mask', 'enter_notify_mask', 'leave_notify_mask', 'button_press_mask', 'button_release_mask' ]);
$darea->signal_connect(enter_notify_event => sub {
if ($darea->{state} == 0) {
$darea->{state} = 1;
&$draw(@_);
}
});
$darea->signal_connect(leave_notify_event => sub {
if ($darea->{state} == 1) {
$darea->{state} = 0;
&$draw(@_);
}
});
$darea->signal_connect(button_release_event => sub {
$darea->{state} = 0;
$darea->draw(undef);
$exec_func->($tag, $exec_hash->{$label});
});
$darea->signal_connect(realize => sub { $darea->window->set_cursor($cursor_hand) });
push @tab, $darea;
}
my $fixed = new Gtk::Fixed;
foreach (@tab) { $fixed->put($_, 75, 65) }
my $w_ret = createScrolledWindow($fixed, undef, 'none');
my $redraw_function = sub {
$fixed->move(@$_) foreach compute_icons($fixed->allocation->[2], $fixed->allocation->[3], 40, 15, 20, @tab);
};
$fixed->signal_connect(expose_event => $redraw_function);
$fixed->signal_connect(realize => sub { $fixed->window->set_back_pixmap($background, 0) });
$fixed->{redraw_function} = $redraw_function;
$w_ret->vscrollbar->set_usize(19, undef);
gtkhide($w_ret);
}
sub n_line_size {
my ($nbline, $type, $widget) = @_;
my $font = $widget->style->font;
my $spacing = ${{ text => 0, various => 17 }}{$type};
$nbline * ($font->ascent + $font->descent + $spacing) + 8;
}
sub write_on_pixmap {
my ($pixmap, $x_pos, $y_pos, @text) = @_;
my ($gdkpixmap, undef) = $pixmap->get();
my ($width, $height) = (440, 250);
my $gc = Gtk::Gdk::GC->new(gtkroot());
$gc->set_foreground(gtkcolor(8448, 17664, 40191)); #- in hex : 33, 69, 157
my $darea = new Gtk::DrawingArea();
$darea->size($width, $height);
$darea->set_usize($width, $height);
my $draw = sub {
my $style = new Gtk::Style;
#- i18n : you can change the font.
$style->font(Gtk::Gdk::Font->fontset_load(N("-adobe-times-bold-r-normal--17-*-100-100-p-*-iso8859-*,*-r-*")));
my $y_pos2 = $y_pos;
foreach (@text) {
$darea->window->draw_string($style->font, $gc, $x_pos, $y_pos2, $_);
$y_pos2 += 20;
}
};
$darea->signal_connect(expose_event => sub { $darea->window->draw_rectangle($darea->style->white_gc, 1, 0, 0, $width, $height);
$darea->window->draw_pixmap(
$darea->style->white_gc,
$gdkpixmap, 0, 0,
($darea->allocation->[2]-$width)/2, ($darea->allocation->[3]-$height)/2,
$width, $height);
&$draw();
});
$darea;
}
#-#######################
# kind of private gtk routines
#-#######################
sub create_pix_text {
#ref widget, txt, color_txt, [font], [width], [height], flag1, flag2, [ (background background_highlighted background_selecteded) backsize x y], centeredx, centeredy
my ($w, $text, $font, $max_width, $max_height, $can_be_greater, $can_be_smaller, $backgrounds, $x_back, $y_back, $centeredx, $centeredy) = @_;
my $fake_darea = new Gtk::DrawingArea;
my $style = $fake_darea->style->copy();
if (ref($font) eq 'Gtk::Gdk::Font') {
$style->font($font);
} else {
$font and $style->font(Gtk::Gdk::Font->fontset_load($font));
}
$fake_darea->set_style($style);
my ($width, $height, $lines, $widths, $heights) = get_text_coord(
$text, $fake_darea, $max_width, $max_height, $can_be_greater, $can_be_smaller, $centeredx, $centeredy);
my $pix;
my $j = 0;
foreach (@$backgrounds) {
$pix->[$j] = new Gtk::Gdk::Pixmap($w->window, $width, $height);
fill_tiled($w, $pix->[$j], $backgrounds->[$j], $x_back, $y_back, $width, $height);
$j++;
}
my $color_text = gtkcolor(0, 0, 0);
my $gc_text = new Gtk::Gdk::GC($w->window);
$gc_text->set_foreground($color_text);
my $i = 0;
foreach (@{$lines}) {
$j = 0;
foreach my $pix (@$pix) {
$pix->draw_string($style->font, $gc_text, ${$widths}[$i], ${$heights}[$i], $_);
$pix->draw_string($style->font, $gc_text, ${$widths}[$i] + 1, ${$heights}[$i], $_) if $j;
$j++;
}
$i++;
}
($pix, $width, $height);
}
sub gtkctree_children {
my ($node) = @_;
my @l;
$node or return;
for (my $p = $node->row->children; $p; $p = $p->row->sibling) {
push @l, $p;
}
@l;
}
sub gtkpowerpack {
#- Get Default Attributes (if any). 2 syntaxes allowed :
#- gtkpowerpack( {expand => 1, fill => 0}, $box...) : the attributes are picked from a specified hash ref
#- gtkpowerpack(1,0,1, $box, ...) : the attributes are picked from the non-ref list, in the order (expand, fill, padding, pack_end).
my $RefDefaultAttrs;
if (ref($_[0]) eq 'HASH') { $RefDefaultAttrs = shift }
elsif (!ref($_[0])) {
$RefDefaultAttrs = {};
foreach ("expand", "fill", "padding", "pack_end") {
!ref($_[0]) ? ($RefDefaultAttrs->{$_} = shift) : last
}
}
my $box = shift;
while (@_) {
#- Get attributes (if specified). 4 syntaxes allowed (default values are undef ie. false...) :
#- gtkpowerpack({defaultattrs}, $box, $widget1, $widget2, ...) : the attrs are picked from the default ones (if they exist)
#- gtkpowerpack($box, {fill=>1, expand=>0, ...}, $widget1, ...) : the attributes are picked from a specified hash ref
#- gtkpowerpack($box, [1,0,1], $widget1, ...) : the attributes are picked from the array ref : (expand, fill, padding, pack_end).
#- gtkpowerpack({attr=>'arg'}, $box, 1, $widget1, 0, $widget2, etc...) : the 'arg' value will tell gtkpowerpack to always read the
#- attr value directly in the arg list (avoiding confusion between value 0 and Gtk::Label("0"). That can simplify some writings but
#- this arg(s) MUST then be present...
my %attr;
my $RefAttrs;
ref($_[0]) eq 'HASH' || ref($_[0]) eq 'ARRAY' and $RefAttrs = shift;
foreach ("expand", "fill", "padding", "pack_end") {
if ($RefDefaultAttrs->{$_} eq 'arg') {
ref $_[0] and die "error in packing definition\n";
$attr{$_} = shift;
ref($RefAttrs) eq 'ARRAY' and shift @$RefAttrs;
} elsif (ref($RefAttrs) eq 'HASH' && defined($RefAttrs->{$_})) {
$attr{$_} = $RefAttrs->{$_};
} elsif (ref($RefAttrs) eq 'ARRAY') {
$attr{$_} = shift @$RefAttrs;
} elsif (defined($RefDefaultAttrs->{$_})) {
$attr{$_} = int $RefDefaultAttrs->{$_};
} else {
$attr{$_} = 0;
}
}
#- Get and pack the widget (create it if necessary when it is a label...)
my $widget = ref($_[0]) ? shift : new Gtk::Label(shift);
if ($attr{pack_end}) { $box->pack_end($widget, $attr{expand}, $attr{fill}, $attr{padding}) }
else { $box->pack_start($widget, $attr{expand}, $attr{fill}, $attr{padding}) }
$widget->show;
}
$box
}
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_imlib {
my ($f) = shift;
$f =~ m|.png$| or $f = "$f.png";
if ($f !~ /\//) { -e "$_/$f" and $f = "$_/$f", last foreach icon_paths() }
Gtk::Gdk::ImlibImage->load_image($f);
}
sub gtkxpm { new Gtk::Pixmap(gtkcreate_xpm(@_)) }
sub gtkpng { new Gtk::Pixmap(gtkcreate_png(@_)) }
sub gtkcreate_xpm {
my ($f) = @_;
my $rw = gtkroot();
$f =~ m|.xpm$| or $f = "$f.xpm";
if ($f !~ /\//) { -e "$_/$f" and $f = "$_/$f", last foreach icon_paths() }
my @l = Gtk::Gdk::Pixmap->create_from_xpm($rw, new Gtk::Style->bg('normal'), $f) or die "gtkcreate_xpm: missing pixmap file $f";
@l;
}
sub gtkcreate_png_pixbuf {
my ($f) = shift;
die 'gdk-pixbuf library is not available' unless $use_pixbuf;
$f =~ /\.(png|jpg)$/ or $f .= '.png';
if ($f !~ /^\//) { -e "$_/$f" and $f = "$_/$f", last foreach icon_paths() }
Gtk::Gdk::Pixbuf->new_from_file($f) or die "gtkcreate_png: missing png file $f";
}
sub gtkcreate_png {
my ($f) = shift;
$f =~ /\.png$/ or $f .= '.png';
if ($f !~ /^\//) { -e "$_/$f" and $f = "$_/$f", last foreach icon_paths() }
if ($use_imlib) {
my $im = Gtk::Gdk::ImlibImage->load_image($f) or die "gtkcreate_png: missing png file $f";
$im->render($im->rgb_width, $im->rgb_height);
return ($im->move_image(), $im->move_mask);
} elsif ($use_pixbuf) {
# my $pixbuf = gtkcreate_png_pixbuf($f);
my $pixbuf = Gtk::Gdk::Pixbuf->new_from_file($f) or die "gtkcreate_png: missing png file $f";
my ($width, $height) = ($pixbuf->get_width(), $pixbuf->get_height);
my $rw = gtkroot();
my $pix = new Gtk::Gdk::Pixmap($rw, $width, $height, 16);
$pixbuf->render_to_drawable_alpha($pix, 0, 0, 0, 0, $width, $height, 'bilevel', 127, 'normal', 0, 0);
my $bit = new Gtk::Gdk::Bitmap($rw, $width, $height, 1);
$pixbuf->render_threshold_alpha($bit, 0, 0, 0, 0, $width, $height, '127');
return ($pix, $bit);
} else {
die "gtkcreate_png: cannot find a suitable library for rendering png (imlib1 or gdk_pixbuf)";
}
}
sub compose_pixbufs {
my ($pixbuf, $back_pixbuf_unaltered, $alpha_threshold) = @_;
$alpha_threshold ||= 255;
my ($width, $height) = ($pixbuf->get_height, $pixbuf->get_width);
my $back_pixbuf = Gtk::Gdk::Pixbuf->new('rgb', 0, 8, $height, $width);
$back_pixbuf_unaltered->copy_area(0, 0, $height, $width, $back_pixbuf, 0, 0);
$pixbuf->composite($back_pixbuf, 0, 0, $width, $height, 0, 0, 1, 1, 'nearest', $alpha_threshold);
$back_pixbuf;
}
sub compose_with_back {
my ($f, $back_pixbuf_unaltered, $alpha_threshold) = @_;
compose_pixbufs(gtkcreate_png_pixbuf($f), $back_pixbuf_unaltered, $alpha_threshold);
}
sub xpm_d { my $w = shift; Gtk::Gdk::Pixmap->create_from_xpm_d($w->window, undef, @_) }
sub fill_tiled {
my ($w, $pix, $bitmap, $x_back, $y_back, $width, $height) = @_;
my ($x2, $y2) = (0, 0);
while (1) {
$x2 = 0;
while (1) {
$pix->draw_pixmap($w->style->bg_gc('normal'),
$bitmap, 0, 0, $x2, $y2, $x_back, $y_back);
$x2 += $x_back;
$x2 >= $width and last;
}
$y2 += $y_back;
$y2 >= $height and last;
}
}
sub compute_icons {
my ($fx, $_fy, $decx, $decy, $interstice, @tab) = @_;
my $nb = $#tab;
my $nb_sav = $nb;
my $index = 0;
my @dx2;
my @dx;
my @dy;
my $line_up = 0;
bcl_init:
@dx2 = undef;
bcl:
@dx = map { $_->{dx} || 78 } @tab[$index..$index+$nb];
$dy[$index] = max(map { $_->{dy} || 89 } @tab[$index..$index+$nb]);
foreach (0..$#dx) {
if ($dx[$_] > $dx2[$_]) { $dx2[$_] = $dx[$_] } else { $dx[$_] = $dx2[$_] }
}
my $line_size = 0;
$line_size = $decx + sum(@dx2) + $nb * $interstice;
if ($line_size > $fx) {
$index = 0; $nb--; goto bcl_init;
}
$nb and $line_up = ($fx-$line_size)/($nb+2);
$index += $nb+1;
$index <= $#tab and goto bcl;
my @ret;
my $n = 0;
my $y = $decy;
my $x = $decx/2 + $line_up;
foreach (0..$nb_sav) {
$ret[$_] = [$tab[$_], $x, $y];
$x += $dx2[$n] + $interstice + $line_up;
$n++;
if ($n > $nb) {
$n = 0;
$x = $decx/2 + $line_up;
$y += int($dy[$_-$nb]/5)*5 + 15;
}
}
@ret;
}
1;