;
chomp $ret if defined $ret;
$this->display_nowrap("\n");
return $ret;
}
sub prompt_password {
my $this=shift;
my %params=@_;
delete $params{default};
system('stty -echo 2>/dev/null');
my $ret=$this->Debconf::FrontEnd::Teletype::prompt(%params);
system('stty sane 2>/dev/null');
return $ret;
}
1
Debconf/FrontEnd/Passthrough.pm 0000666 00000014446 15077711155 0012516 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::FrontEnd::Passthrough;
use strict;
use Carp;
use IO::Socket;
use IO::Handle;
use Debconf::FrontEnd;
use Debconf::Element;
use Debconf::Element::Select;
use Debconf::Element::Multiselect;
use Debconf::Log qw(:all);
use Debconf::Encoding;
use base qw(Debconf::FrontEnd);
my ($READFD, $WRITEFD, $SOCKET);
if (defined $ENV{DEBCONF_PIPE}) {
$SOCKET = $ENV{DEBCONF_PIPE};
} elsif (defined $ENV{DEBCONF_READFD} && defined $ENV{DEBCONF_WRITEFD}) {
$READFD = $ENV{DEBCONF_READFD};
$WRITEFD = $ENV{DEBCONF_WRITEFD};
} else {
die "Neither DEBCONF_PIPE nor DEBCONF_READFD and DEBCONF_WRITEFD were set\n";
}
sub init {
my $this=shift;
if (defined $SOCKET) {
$this->{readfh} = $this->{writefh} = IO::Socket::UNIX->new(
Type => SOCK_STREAM,
Peer => $SOCKET
) || croak "Cannot connect to $SOCKET: $!";
} else {
$this->{readfh} = IO::Handle->new_from_fd(int($READFD), "r") || croak "Failed to open fd $READFD: $!";
$this->{writefh} = IO::Handle->new_from_fd(int($WRITEFD), "w") || croak "Failed to open fd $WRITEFD: $!";
}
binmode $this->{readfh}, ":utf8";
binmode $this->{writefh}, ":utf8";
$this->{readfh}->autoflush(1);
$this->{writefh}->autoflush(1);
$this->elements([]);
$this->interactive(1);
$this->need_tty(0);
}
sub talk {
my $this=shift;
my $command=join(' ', map { Debconf::Encoding::to_Unicode($_) } @_);
my $reply;
my $readfh = $this->{readfh} || croak "Broken pipe";
my $writefh = $this->{writefh} || croak "Broken pipe";
debug developer => "----> $command";
print $writefh $command."\n";
$writefh->flush;
$reply = <$readfh>;
chomp($reply);
debug developer => "<---- $reply";
my ($tag, $val) = split(' ', $reply, 2);
$val = '' unless defined $val;
$val = Debconf::Encoding::convert("UTF-8", $val);
return ($tag, $val) if wantarray;
return $tag;
}
sub makeelement
{
my $this=shift;
my $question=shift;
my $type=$question->type;
if ($type eq "select" || $type eq "multiselect") {
$type=ucfirst($type);
return "Debconf::Element::$type"->new(question => $question);
} else {
return Debconf::Element->new(question => $question);
}
}
sub capb_backup
{
my $this=shift;
my $val = shift;
$this->{capb_backup} = $val;
$this->talk('CAPB', 'backup') if $val;
}
sub capb
{
my $this=shift;
my $ret;
return $this->{capb} if exists $this->{capb};
($ret, $this->{capb}) = $this->talk('CAPB');
return $this->{capb} if $ret eq '0';
}
sub title
{
my $this = shift;
return $this->{title} unless @_;
my $title = shift;
$this->{title} = $title;
$this->talk('TITLE', $title);
}
sub settitle
{
my $this = shift;
my $question = shift;
$this->{title} = $question->description;
my $tag = $question->template->template;
my $type = $question->template->type;
my $desc = $question->description;
my $extdesc = $question->extended_description;
$this->talk('DATA', $tag, 'type', $type);
if ($desc) {
$desc =~ s/\n/\\n/g;
$this->talk('DATA', $tag, 'description', $desc);
}
if ($extdesc) {
$extdesc =~ s/\n/\\n/g;
$this->talk('DATA', $tag, 'extended_description', $extdesc);
}
$this->talk('SETTITLE', $tag);
}
sub go {
my $this = shift;
my @elements=grep $_->visible, @{$this->elements};
foreach my $element (@elements) {
my $question = $element->question;
my $tag = $question->template->template;
my $type = $question->template->type;
my $desc = $question->description;
my $extdesc = $question->extended_description;
my $default;
if ($type eq 'select') {
$default = $element->translate_default;
} elsif ($type eq 'multiselect') {
$default = join ', ', $element->translate_default;
} else {
$default = $question->value;
}
$this->talk('DATA', $tag, 'type', $type);
if ($desc) {
$desc =~ s/\n/\\n/g;
$this->talk('DATA', $tag, 'description', $desc);
}
if ($extdesc) {
$extdesc =~ s/\n/\\n/g;
$this->talk('DATA', $tag, 'extended_description',
$extdesc);
}
if ($type eq "select" || $type eq "multiselect") {
my $choices = $question->choices;
$choices =~ s/\n/\\n/g if ($choices);
$this->talk('DATA', $tag, 'choices', $choices);
}
$this->talk('SET', $tag, $default) if $default ne '';
my @vars=$Debconf::Db::config->variables($question->{name});
for my $var (@vars) {
my $val=$Debconf::Db::config->getvariable($question->{name}, $var);
$val='' unless defined $val;
$this->talk('SUBST', $tag, $var, $val);
}
$this->talk('INPUT', $question->priority, $tag);
}
if (@elements && (scalar($this->talk('GO')) eq "30") && $this->{capb_backup}) {
return;
}
foreach my $element (@{$this->elements}) {
if ($element->visible) {
my $tag = $element->question->template->template;
my $type = $element->question->template->type;
my ($ret, $val)=$this->talk('GET', $tag);
if ($ret eq "0") {
if ($type eq 'select') {
$element->value($element->translate_to_C($val));
} elsif ($type eq 'multiselect') {
$element->value(join(', ', map { $element->translate_to_C($_) } split(', ', $val)));
} else {
$element->value($val);
}
debug developer => "Got \"$val\" for $tag";
}
} else {
$element->show;
}
}
return 1;
}
sub progress_data {
my $this=shift;
my $question=shift;
my $tag=$question->template->template;
my $type=$question->template->type;
my $desc=$question->description;
my $extdesc=$question->extended_description;
$this->talk('DATA', $tag, 'type', $type);
if ($desc) {
$desc =~ s/\n/\\n/g;
$this->talk('DATA', $tag, 'description', $desc);
}
if ($extdesc) {
$extdesc =~ s/\n/\\n/g;
$this->talk('DATA', $tag, 'extended_description', $extdesc);
}
}
sub progress_start {
my $this=shift;
$this->progress_data($_[2]);
return $this->talk('PROGRESS', 'START', $_[0], $_[1], $_[2]->template->template);
}
sub progress_set {
my $this=shift;
return (scalar($this->talk('PROGRESS', 'SET', $_[0])) ne "30");
}
sub progress_step {
my $this=shift;
return (scalar($this->talk('PROGRESS', 'STEP', $_[0])) ne "30");
}
sub progress_info {
my $this=shift;
$this->progress_data($_[0]);
return (scalar($this->talk('PROGRESS', 'INFO', $_[0]->template->template)) ne "30");
}
sub progress_stop {
my $this=shift;
return $this->talk('PROGRESS', 'STOP');
}
1
Debconf/FrontEnd/Gnome.pm 0000666 00000007164 15077711155 0011253 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::FrontEnd::Gnome;
use strict;
use utf8;
use Debconf::Gettext;
use Debconf::Config;
use Debconf::Encoding qw(to_Unicode);
use base qw{Debconf::FrontEnd};
eval q{
use Gtk2;
use Gnome2;
};
die "Unable to load Gnome -- is libgnome2-perl installed?\n" if $@;
our @ARGV_for_gnome=('--sm-disable');
sub create_druid_page {
my $this=shift;
$this->druid_page(Gnome2::DruidPageStandard->new);
$this->druid_page->set_logo($this->logo);
$this->druid_page->signal_connect("back", sub {
$this->goback(1);
Gtk2->main_quit;
return 1;
});
$this->druid_page->signal_connect("next", sub {
$this->goback(0);
Gtk2->main_quit;
return 1;
});
$this->druid_page->signal_connect("cancel", sub { exit 1 });
$this->druid_page->show;
$this->druid->append_page($this->druid_page);
$this->druid->set_page($this->druid_page);
}
sub init {
my $this=shift;
if (fork) {
wait(); # for child
if ($? != 0) {
die "DISPLAY problem?\n";
}
}
else {
@ARGV=@ARGV_for_gnome; # temporary change at first
Gnome2::Program->init('GNOME Debconf', '2.0');
exit(0); # success
}
my @gnome_sucks=@ARGV;
@ARGV=@ARGV_for_gnome;
Gnome2::Program->init('GNOME Debconf', '2.0');
@ARGV=@gnome_sucks;
$this->SUPER::init(@_);
$this->interactive(1);
$this->capb('backup');
$this->need_tty(0);
$this->win(Gtk2::Window->new("toplevel"));
$this->win->set_position("center");
$this->win->set_default_size(600, 400);
my $hostname = `hostname`;
chomp $hostname;
$this->win->set_title(to_Unicode(sprintf(gettext("Debconf on %s"), $hostname)));
$this->win->signal_connect("delete_event", sub { exit 1 });
my $distribution='';
if (system('type lsb_release >/dev/null 2>&1') == 0) {
$distribution=lc(`lsb_release -is`);
chomp $distribution;
} elsif (-e '/etc/debian_version') {
$distribution='debian';
}
my $logo="/usr/share/pixmaps/$distribution-logo.png";
if (-e $logo) {
$this->logo(Gtk2::Gdk::Pixbuf->new_from_file($logo));
}
$this->druid(Gnome2::Druid->new);
$this->druid->show;
$this->win->add($this->druid);
$this->create_druid_page ();
}
sub go {
my $this=shift;
my @elements=@{$this->elements};
my $interactive='';
foreach my $element (@elements) {
next unless $element->hbox;
$interactive=1;
$this->druid_page->vbox->pack_start($element->hbox, $element->fill, $element->expand, 0);
}
if ($interactive) {
$this->druid_page->set_title(to_Unicode($this->title));
if ($this->capb_backup) {
$this->druid->set_buttons_sensitive(1, 1, 1, 1);
}
else {
$this->druid->set_buttons_sensitive(0, 1, 1, 1);
}
$this->win->show;
Gtk2->main;
$this->create_druid_page ();
}
foreach my $element (@elements) {
$element->show;
}
return '' if $this->goback;
return 1;
}
sub progress_start {
my $this=shift;
$this->SUPER::progress_start(@_);
my $element=$this->progress_bar;
$this->druid_page->vbox->pack_start($element->hbox, $element->fill, $element->expand, 0);
$this->druid_page->set_title(to_Unicode($this->title));
$this->druid->set_buttons_sensitive(0, 0, 1, 1);
$this->win->show;
while (Gtk2->events_pending) {
Gtk2->main_iteration;
}
}
sub progress_set {
my $this=shift;
my $ret=$this->SUPER::progress_set(@_);
while (Gtk2->events_pending) {
Gtk2->main_iteration;
}
return $ret;
}
sub progress_info {
my $this=shift;
my $ret=$this->SUPER::progress_info(@_);
while (Gtk2->events_pending) {
Gtk2->main_iteration;
}
return $ret;
}
sub progress_stop {
my $this=shift;
$this->SUPER::progress_stop(@_);
while (Gtk2->events_pending) {
Gtk2->main_iteration;
}
$this->create_druid_page();
}
1
Debconf/FrontEnd/Dialog.pm 0000666 00000016224 15077711155 0011402 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::FrontEnd::Dialog;
use strict;
use Debconf::Gettext;
use Debconf::Priority;
use Debconf::TmpFile;
use Debconf::Log qw(:all);
use Debconf::Encoding qw(wrap $columns width);
use IPC::Open3;
use POSIX;
use Fcntl;
use base qw(Debconf::FrontEnd::ScreenSize);
sub init {
my $this=shift;
$this->SUPER::init(@_);
delete $ENV{POSIXLY_CORRECT} if exists $ENV{POSIXLY_CORRECT};
delete $ENV{POSIX_ME_HARDER} if exists $ENV{POSIX_ME_HARDER};
if (! exists $ENV{TERM} || ! defined $ENV{TERM} || $ENV{TERM} eq '') {
die gettext("TERM is not set, so the dialog frontend is not usable.")."\n";
}
elsif ($ENV{TERM} =~ /emacs/i) {
die gettext("Dialog frontend is incompatible with emacs shell buffers")."\n";
}
elsif ($ENV{TERM} eq 'dumb' || $ENV{TERM} eq 'unknown') {
die gettext("Dialog frontend will not work on a dumb terminal, an emacs shell buffer, or without a controlling terminal.")."\n";
}
$this->interactive(1);
$this->capb('backup');
if (-x "/usr/bin/whiptail" &&
(! defined $ENV{DEBCONF_FORCE_DIALOG} || ! -x "/usr/bin/dialog") &&
(! defined $ENV{DEBCONF_FORCE_XDIALOG} || ! -x "/usr/bin/Xdialog")) {
$this->program('whiptail');
$this->dashsep('--');
$this->borderwidth(5);
$this->borderheight(6);
$this->spacer(1);
$this->titlespacer(10);
$this->columnspacer(3);
$this->selectspacer(13);
$this->hasoutputfd(1);
}
elsif (-x "/usr/bin/dialog" &&
(! defined $ENV{DEBCONF_FORCE_XDIALOG} || ! -x "/usr/bin/Xdialog")) {
$this->program('dialog');
$this->dashsep(''); # dialog does not need (or support)
$this->borderwidth(7);
$this->borderheight(6);
$this->spacer(0);
$this->titlespacer(4);
$this->columnspacer(2);
$this->selectspacer(0);
$this->hasoutputfd(1);
}
elsif (-x "/usr/bin/Xdialog" && defined $ENV{DISPLAY}) {
$this->program("Xdialog");
$this->borderwidth(7);
$this->borderheight(20);
$this->spacer(0);
$this->titlespacer(10);
$this->selectspacer(0);
$this->columnspacer(2);
$this->screenheight(200);
}
else {
die gettext("No usable dialog-like program is installed, so the dialog based frontend cannot be used.");
}
if ($this->screenheight < 13 || $this->screenwidth < 31) {
die gettext("Dialog frontend requires a screen at least 13 lines tall and 31 columns wide.")."\n";
}
}
sub sizetext {
my $this=shift;
my $text=shift;
$columns = $this->screenwidth - $this->borderwidth - $this->columnspacer;
$text=wrap('', '', $text);
my @lines=split(/\n/, $text);
my $window_columns=width($this->title) + $this->titlespacer;
map {
my $w=width($_);
$window_columns = $w if $w > $window_columns;
} @lines;
return $text, $#lines + 1 + $this->borderheight,
$window_columns + $this->borderwidth;
}
sub hide_escape {
my $line = $_;
$line =~ s/\\n/\\\xe2\x81\xa0n/g;
return $line;
}
sub showtext {
my $this=shift;
my $question=shift;
my $intext=shift;
my $lines = $this->screenheight;
my ($text, $height, $width)=$this->sizetext($intext);
my @lines = split(/\n/, $text);
my $num;
my @args=('--msgbox', join("\n", @lines));
if ($lines - 4 - $this->borderheight <= $#lines) {
$num=$lines - 4 - $this->borderheight;
if ($this->program eq 'whiptail') {
push @args, '--scrolltext';
}
else {
my $fh=Debconf::TmpFile::open();
print $fh join("\n", map &hide_escape, @lines);
close $fh;
@args=("--textbox", Debconf::TmpFile::filename());
}
}
else {
$num=$#lines + 1;
}
$this->showdialog($question, @args, $num + $this->borderheight, $width);
if ($args[0] eq '--textbox') {
Debconf::TmpFile::cleanup();
}
}
sub makeprompt {
my $this=shift;
my $question=shift;
my $freelines=$this->screenheight - $this->borderheight + 1;
$freelines += shift if @_;
my ($text, $lines, $columns)=$this->sizetext(
$question->extended_description."\n\n".
$question->description
);
if ($lines > $freelines) {
$this->showtext($question, $question->extended_description);
($text, $lines, $columns)=$this->sizetext($question->description);
}
return ($text, $lines, $columns);
}
sub startdialog {
my $this=shift;
my $question=shift;
my $wantinputfd=shift;
debug debug => "preparing to run dialog. Params are:" ,
join(",", $this->program, @_);
use vars qw{*SAVEOUT *SAVEIN};
open(SAVEOUT, ">&STDOUT") || die $!;
$this->dialog_saveout(\*SAVEOUT);
if ($wantinputfd) {
$this->dialog_savein(undef);
} else {
open(SAVEIN, "<&STDIN") || die $!;
$this->dialog_savein(\*SAVEIN);
}
$this->dialog_savew($^W);
$^W=0;
unless ($this->capb_backup || grep { $_ eq '--defaultno' } @_) {
if ($this->program ne 'Xdialog') {
unshift @_, '--nocancel';
}
else {
unshift @_, '--no-cancel';
}
}
if ($this->program eq 'Xdialog' && $_[0] eq '--passwordbox') {
$_[0]='--password --inputbox'
}
use vars qw{*OUTPUT_RDR *OUTPUT_WTR};
if ($this->hasoutputfd) {
pipe(OUTPUT_RDR, OUTPUT_WTR) || die "pipe: $!";
my $flags=fcntl(\*OUTPUT_WTR, F_GETFD, 0);
fcntl(\*OUTPUT_WTR, F_SETFD, $flags & ~FD_CLOEXEC);
$this->dialog_output_rdr(\*OUTPUT_RDR);
unshift @_, "--output-fd", fileno(\*OUTPUT_WTR);
}
my $backtitle='';
if (defined $this->info) {
$backtitle = $this->info->description;
} else {
$backtitle = gettext("Package configuration");
}
use vars qw{*INPUT_RDR *INPUT_WTR};
if ($wantinputfd) {
pipe(INPUT_RDR, INPUT_WTR) || die "pipe: $!";
autoflush INPUT_WTR 1;
my $flags=fcntl(\*INPUT_RDR, F_GETFD, 0);
fcntl(\*INPUT_RDR, F_SETFD, $flags & ~FD_CLOEXEC);
$this->dialog_input_wtr(\*INPUT_WTR);
} else {
$this->dialog_input_wtr(undef);
}
use vars qw{*ERRFH};
my $pid = open3($wantinputfd ? '<&INPUT_RDR' : '<&STDIN', '>&STDOUT',
\*ERRFH, $this->program,
'--backtitle', $backtitle,
'--title', $this->title, @_);
$this->dialog_errfh(\*ERRFH);
$this->dialog_pid($pid);
close OUTPUT_WTR if $this->hasoutputfd;
}
sub waitdialog {
my $this=shift;
my $input_wtr=$this->dialog_input_wtr;
if ($input_wtr) {
close $input_wtr;
}
my $output_rdr=$this->dialog_output_rdr;
my $errfh=$this->dialog_errfh;
my $output='';
if ($this->hasoutputfd) {
while (<$output_rdr>) {
$output.=$_;
}
my $error=0;
while (<$errfh>) {
print STDERR $_;
$error++;
}
if ($error) {
die sprintf("debconf: %s output the above errors, giving up!", $this->program)."\n";
}
}
else {
while (<$errfh>) { # ugh
$output.=$_;
}
}
chomp $output;
waitpid($this->dialog_pid, 0);
$^W=$this->dialog_savew;
if (defined $this->dialog_savein) {
open(STDIN, '<&', $this->dialog_savein) || die $!;
}
open(STDOUT, '>&', $this->dialog_saveout) || die $!;
my $ret=$? >> 8;
if ($ret == 255 || ($ret == 1 && join(' ', @_) !~ m/--yesno\s/)) {
$this->backup(1);
return undef;
}
if (wantarray) {
return $ret, $output;
}
else {
return $output;
}
}
sub showdialog {
my $this=shift;
my $question=shift;
@_=map &hide_escape, @_;
if (defined $this->progress_bar) {
$this->progress_bar->stop;
}
$this->startdialog($question, 0, @_);
my (@ret, $ret);
if (wantarray) {
@ret=$this->waitdialog(@_);
} else {
$ret=$this->waitdialog(@_);
}
if (defined $this->progress_bar) {
$this->progress_bar->start;
}
if (wantarray) {
return @ret;
} else {
return $ret;
}
}
1
Debconf/FrontEnd/Kde.pm 0000666 00000010471 15077711155 0010704 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::FrontEnd::Kde;
use strict;
use utf8;
use Debconf::Gettext;
use Debconf::Config;
BEGIN {
eval { require QtCore4 };
die "Unable to load QtCore -- is libqtcore4-perl installed?\n" if $@;
eval { require QtGui4 };
die "Unable to load QtGui -- is libqtgui4-perl installed?\n" if $@;
}
use Debconf::FrontEnd::Kde::Wizard;
use Debconf::Log ':all';
use base qw{Debconf::FrontEnd};
use Debconf::Encoding qw(to_Unicode);
our @ARGV_KDE=();
sub init {
my $this=shift;
$this->SUPER::init(@_);
$this->interactive(1);
$this->cancelled(0);
$this->createdelements([]);
$this->dupelements([]);
$this->capb('backup');
$this->need_tty(0);
if (fork) {
wait(); # for child
if ($? != 0) {
die "DISPLAY problem?\n";
}
}
else {
$this->qtapp(Qt::Application(\@ARGV_KDE));
exit(0); # success
}
$this->window_initted(0);
$this->kde_initted(0);
}
sub init_kde {
my $this=shift;
return if $this->kde_initted;
debug frontend => "QTF: initializing app";
$this->qtapp(Qt::Application(\@ARGV_KDE));
$this->kde_initted(1);
}
sub init_window {
my $this=shift;
$this->init_kde();
return if $this->window_initted;
$this->{vbox} = Qt::VBoxLayout;
debug frontend => "QTF: initializing wizard";
$this->win(Debconf::FrontEnd::Kde::Wizard(undef,undef, $this));
debug frontend => "QTF: setting size";
$this->win->resize(620, 430);
my $hostname = `hostname`;
chomp $hostname;
$this->hostname($hostname);
debug frontend => "QTF: setting title";
$this->win->setTitle(to_Unicode(sprintf(gettext("Debconf on %s"), $this->hostname)));
debug frontend => "QTF: initializing main widget";
$this->{toplayout} = Qt::HBoxLayout();
$this->win->setMainFrameLayout($this->toplayout);
$this->win->setTitle(to_Unicode(sprintf(gettext("Debconf on %s"), $this->hostname)));
$this->window_initted(1);
}
sub go {
my $this=shift;
my @elements=@{$this->elements};
$this->init_window;
my $interactive='';
debug frontend => "QTF: -- START ------------------";
foreach my $element (@elements) {
next unless $element->can("create");
$element->create($this->frame);
$interactive=1;
debug frontend => "QTF: ADD: " . $element->question->description;
$this->{vbox}->addWidget($element->top);
}
if ($interactive) {
foreach my $element (@elements) {
next unless $element->top;
debug frontend => "QTF: SHOW: " . $element->question->description;
$element->top->show;
}
my $scroll = Qt::ScrollArea($this->win);
my $widget = Qt::Widget($scroll);
$widget->setLayout($this->{vbox});
$scroll->setWidget($widget);
$this->toplayout->addWidget($scroll);
if ($this->capb_backup) {
$this->win->setBackEnabled(1);
}
else {
$this->win->setBackEnabled(0);
}
$this->win->setNextEnabled(1);
$this->win->show;
debug frontend => "QTF: -- ENTER EVENTLOOP --------";
$this->qtapp->exec;
$this->qtapp->exit;
debug frontend => "QTF: -- LEFT EVENTLOOP --------";
$this->win->destroy();
$this->window_initted(0);
} else {
foreach my $element (@elements) {
$element->show;
}
}
debug frontend => "QTF: -- END --------------------";
if ($this->cancelled) {
exit 1;
}
return '' if $this->goback;
return 1;
}
sub progress_start {
my $this=shift;
$this->init_window;
$this->SUPER::progress_start(@_);
my $element=$this->progress_bar;
$this->{vbox}->addWidget($element->top);
$element->top->show;
my $scroll = Qt::ScrollArea($this->win);
my $widget = Qt::Widget($scroll);
$widget->setLayout($this->{vbox});
$scroll->setWidget($widget);
$this->toplayout->addWidget($scroll);
$this->win->setBackEnabled(0);
$this->win->setNextEnabled(0);
$this->win->show;
$this->qtapp->processEvents;
}
sub progress_set {
my $this=shift;
my $ret=$this->SUPER::progress_set(@_);
$this->qtapp->processEvents;
return $ret;
}
sub progress_info {
my $this=shift;
my $ret=$this->SUPER::progress_info(@_);
$this->qtapp->processEvents;
return $ret;
}
sub progress_stop {
my $this=shift;
my $element=$this->progress_bar;
$this->SUPER::progress_stop(@_);
$this->qtapp->processEvents;
$this->win->setAttribute(Qt::WA_DeleteOnClose());
$this->win->close;
$this->window_initted(0);
if ($this->cancelled) {
exit 1;
}
}
sub shutdown {
my $this = shift;
if ($this->kde_initted) {
if($this->win) {
$this->win->destroy;
}
}
}
1
Debconf/FrontEnd/Noninteractive.pm 0000666 00000000402 15077711155 0013162 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::FrontEnd::Noninteractive;
use strict;
use base qw(Debconf::FrontEnd);
sub init {
my $this=shift;
$this->SUPER::init(@_);
$this->need_tty(0);
}
1
Debconf/FrontEnd/Web.pm 0000666 00000005034 15077711155 0010715 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::FrontEnd::Web;
use IO::Socket;
use IO::Select;
use CGI;
use strict;
use Debconf::Gettext;
use base qw(Debconf::FrontEnd);
sub init {
my $this=shift;
$this->SUPER::init(@_);
$this->port(8001) unless defined $this->port;
$this->formid(0);
$this->interactive(1);
$this->capb('backup');
$this->need_tty(0);
$this->server(IO::Socket::INET->new(
LocalPort => $this->port,
Proto => 'tcp',
Listen => 1,
Reuse => 1,
LocalAddr => '127.0.0.1',
)) || die "Can't bind to ".$this->port.": $!";
print STDERR sprintf(gettext("Note: Debconf is running in web mode. Go to http://localhost:%i/"),$this->port)."\n";
}
sub client {
my $this=shift;
$this->{client}=shift if @_;
return $this->{client} if $this->{client};
my $select=IO::Select->new($this->server);
1 while ! $select->can_read(1);
my $client=$this->server->accept;
my $commands='';
while (<$client>) {
last if $_ eq "\r\n";
$commands.=$_;
}
$this->commands($commands);
$this->{client}=$client;
}
sub closeclient {
my $this=shift;
close $this->client;
$this->client('');
}
sub showclient {
my $this=shift;
my $page=shift;
my $client=$this->client;
print $client $page;
}
sub go {
my $this=shift;
$this->backup('');
my $httpheader="HTTP/1.0 200 Ok\nContent-type: text/html\n\n";
my $form='';
my $id=0;
my %idtoelt;
foreach my $elt (@{$this->elements}) {
$idtoelt{$id}=$elt;
$elt->id($id++);
my $html=$elt->show;
if ($html ne '') {
$form.=$html."".$this->title." \n\n".
"\n\n\n";
my $query;
do {
$this->showclient($httpheader . $form);
$this->closeclient;
$this->client;
my @get=grep { /^GET / } split(/\r\n/, $this->commands);
my $get=shift @get;
my ($qs)=$get=~m/^GET\s+.*?\?(.*?)(?:\s+.*)?$/;
$query=CGI->new($qs);
} until ($query->param('formid') eq $formid);
if ($this->capb_backup && $query->param('back') ne '') {
return '';
}
foreach my $id ($query->param) {
next unless $idtoelt{$id};
$idtoelt{$id}->value($query->param($id));
delete $idtoelt{$id};
}
foreach my $elt (values %idtoelt) {
$elt->value('');
}
return 1;
}
1
Debconf/FrontEnd/Text.pm 0000666 00000000233 15077711155 0011120 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::FrontEnd::Text;
use strict;
use base qw(Debconf::FrontEnd::Readline);
1
Debconf/DbDriver.pm 0000666 00000004467 15077711155 0010173 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::DbDriver;
use Debconf::Log qw{:all};
use strict;
use base 1.01; # ensure that they don't have a broken perl installation
use fields qw(name readonly required backup failed
accept_type reject_type accept_name reject_name);
our %drivers;
sub new {
my Debconf::DbDriver $this=shift;
unless (ref $this) {
$this = fields::new($this);
}
$this->{required}=1;
$this->{readonly}=0;
$this->{failed}=0;
my %params=@_;
foreach my $field (keys %params) {
if ($field eq 'readonly' || $field eq 'required' || $field eq 'backup') {
$this->{$field}=1,next if lc($params{$field}) eq "true";
$this->{$field}=0,next if lc($params{$field}) eq "false";
}
elsif ($field=~/^(accept|reject)_/) {
$this->{$field}=qr/$params{$field}/i;
}
$this->{$field}=$params{$field};
}
unless (exists $this->{name}) {
$this->{name}="(unknown)";
$this->error("no name specified");
}
$drivers{$this->{name}} = $this;
$this->init;
return $this;
}
sub init {}
sub error {
my $this=shift;
if ($this->{required}) {
warn('DbDriver "'.$this->{name}.'":', @_);
exit 1;
}
else {
warn('DbDriver "'.$this->{name}.'" warning:', @_);
}
}
sub driver {
my $this=shift;
my $name=shift;
return $drivers{$name};
}
sub accept {
my $this=shift;
my $name=shift;
my $type=shift;
return if $this->{failed};
if ((exists $this->{accept_name} && $name !~ /$this->{accept_name}/) ||
(exists $this->{reject_name} && $name =~ /$this->{reject_name}/)) {
debug "db $this->{name}" => "reject $name";
return;
}
if (exists $this->{accept_type} || exists $this->{reject_type}) {
if (! defined $type || ! length $type) {
my $template = Debconf::Template->get($this->getfield($name, 'template'));
return 1 unless $template; # no type to act on
$type=$template->type || '';
}
return if exists $this->{accept_type} && $type !~ /$this->{accept_type}/;
return if exists $this->{reject_type} && $type =~ /$this->{reject_type}/;
}
return 1;
}
sub ispassword {
my $this=shift;
my $item=shift;
my $template=$this->getfield($item, 'template');
return unless defined $template;
$template=Debconf::Template->get($template);
return unless $template;
my $type=$template->type || '';
return 1 if $type eq 'password';
return 0;
}
1
Debconf/Element/Kde/Password.pm 0000666 00000001135 15077711155 0012355 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::Password;
use strict;
use QtCore4;
use QtGui4;
use base qw(Debconf::Element::Kde);
sub create {
my $this=shift;
$this->SUPER::create(@_);
$this->startsect;
$this->widget(Qt::LineEdit($this->cur->top));
$this->widget->show;
$this->widget->setEchoMode(2);
$this->addwidget($this->description);
$this->addhelp;
$this->addwidget($this->widget);
$this->endsect;
}
sub value {
my $this=shift;
my $text = $this->widget->text();
$text = $this->question->value if $text eq '';
return $text;
}
1
Debconf/Element/Kde/Multiselect.pm 0000666 00000002331 15077711155 0013044 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::Multiselect;
use strict;
use QtCore4;
use QtGui4;
use base qw(Debconf::Element::Kde Debconf::Element::Multiselect);
use Debconf::Encoding qw(to_Unicode);
sub create {
my $this=shift;
my @choices = $this->question->choices_split;
my %default = map { $_ => 1 } $this->translate_default;
$this->SUPER::create(@_);
$this->startsect;
$this->adddescription;
$this->addhelp;
my @buttons;
for (my $i=0; $i <= $#choices; $i++) {
$buttons[$i] = Qt::CheckBox($this->cur->top);
$buttons[$i]->setText(to_Unicode($choices[$i]));
$buttons[$i]->show;
$buttons[$i]->setChecked($default{$choices[$i]} ? 1 : 0);
$this->addwidget($buttons[$i]);
}
$this->buttons(\@buttons);
$this->endsect;
}
sub value {
my $this = shift;
my @buttons = @{$this->buttons};
my ($ret, $val);
my @vals;
$this->question->template->i18n('');
my @choices=$this->question->choices_split;
$this->question->template->i18n(1);
for (my $i = 0; $i <= $#choices; $i++) {
if ($buttons [$i] -> isChecked()) {
push @vals, $choices[$i];
}
}
return join(', ', $this->order_values(@vals));
}
*visible = \&Debconf::Element::Multiselect::visible;
1
Debconf/Element/Kde/Error.pm 0000666 00000000523 15077711155 0011644 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::Error;
use strict;
use Debconf::Gettext;
use QtCore4;
use QtGui4;
use base qw(Debconf::Element::Kde);
sub create {
my $this=shift;
$this->SUPER::create(@_);
$this->startsect;
$this->adddescription;
$this->addhelp;
$this->endsect;
}
1
Debconf/Element/Kde/Select.pm 0000666 00000002073 15077711155 0011774 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::Select;
use strict;
use QtCore4;
use QtGui4;
use base qw(Debconf::Element::Kde Debconf::Element::Select);
use Debconf::Encoding qw(to_Unicode);
sub create {
my $this=shift;
my $default=$this->translate_default;
my @choices=map { to_Unicode($_) } $this->question->choices_split;
$this->SUPER::create(@_);
$this->startsect;
$this->widget(Qt::ComboBox($this->cur->top));
$this->widget->show;
$this->widget->addItems(\@choices);
if (defined($default) and length($default) != 0) {
for (my $i = 0 ; $i < @choices ; $i++) {
if ($choices[$i] eq $default ) {
$this->widget->setCurrentIndex($i);# //FIXME find right index to_Unicode($default));
last;
}
}
}
$this->addwidget($this->description);
$this->addhelp;
$this->addwidget($this->widget);
$this->endsect;
}
sub value {
my $this=shift;
my @choices=$this->question->choices_split;
return $this->translate_to_C_uni($this->widget->currentText());
}
*visible = \&Debconf::Element::Select::visible;
1
Debconf/Element/Kde/String.pm 0000666 00000001174 15077711155 0012024 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::String;
use strict;
use QtCore4;
use QtGui4;
use base qw(Debconf::Element::Kde);
use Debconf::Encoding qw(to_Unicode);
sub create {
my $this=shift;
$this->SUPER::create(@_);
$this->startsect;
$this->widget(Qt::LineEdit($this->cur->top));
my $default='';
$default=$this->question->value if defined $this->question->value;
$this->widget->setText(to_Unicode($default));
$this->adddescription;
$this->addhelp;
$this->addwidget ($this->widget);
$this->endsect;
}
sub value {
my $this=shift;
return $this->widget->text();
}
1
Debconf/Element/Kde/Note.pm 0000666 00000000555 15077711155 0011465 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::Note;
use strict;
use Debconf::Gettext;
use Qt;
use Debconf::Element::Noninteractive::Note;
use base qw(Debconf::Element::Kde);
sub create {
my $this=shift;
$this->SUPER::create(@_);
$this->startsect;
$this->adddescription;
$this->addhelp;
$this->endsect;
}
1
Debconf/Element/Kde/Text.pm 0000666 00000000503 15077711155 0011475 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::Text;
use strict;
use Debconf::Gettext;
use Qt;
use base qw(Debconf::Element::Kde);
sub create {
my $this=shift;
$this->SUPER::create(@_);
$this->startsect;
$this->adddescription; # yeah, that's all
$this->endsect;
}
1
Debconf/Element/Kde/Boolean.pm 0000666 00000001332 15077711155 0012131 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::Boolean;
use strict;
use QtCore4;
use QtGui4;
use base qw(Debconf::Element::Kde);
use Debconf::Encoding qw(to_Unicode);
sub create {
my $this=shift;
$this->SUPER::create(@_);
$this->startsect;
$this->widget(Qt::CheckBox( to_Unicode($this->question->description)));
$this->widget->setChecked(($this->question->value eq 'true') ? 1 : 0);
$this->widget->setText(to_Unicode($this->question->description));
$this->adddescription;
$this->addhelp;
$this->addwidget($this->widget);
$this->endsect;
}
sub value {
my $this = shift;
if ($this -> widget -> isChecked) {
return "true";
}
else {
return "false";
}
}
1
Debconf/Element/Kde/Progress.pm 0000666 00000002214 15077711155 0012356 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::Progress;
use strict;
use QtCore4;
use QtGui4;
use base qw(Debconf::Element::Kde);
use Debconf::Encoding qw(to_Unicode);
sub start {
my $this=shift;
my $description=to_Unicode($this->question->description);
my $frontend=$this->frontend;
$this->SUPER::create($frontend->frame);
$this->startsect;
$this->addhelp;
$this->adddescription;
my $vbox = Qt::VBoxLayout($this->widget);
$this->progress_bar(Qt::ProgressBar($this->cur->top));
$this->progress_bar->setMinimum($this->progress_min());
$this->progress_bar->setMaximum($this->progress_max());
$this->progress_bar->show;
$this->addwidget($this->progress_bar);
$this->progress_label(Qt::Label($this->cur->top));
$this->progress_label->show;
$this->addwidget($this->progress_label);
$this->endsect;
}
sub set {
my $this=shift;
my $value=shift;
$this->progress_cur($value);
$this->progress_bar->setValue($this->progress_cur);
return 1;
}
sub info {
my $this=shift;
my $question=shift;
$this->progress_label->setText(to_Unicode($question->description));
return 1;
}
sub stop {
}
1;
Debconf/Element/Noninteractive/Password.pm 0000666 00000000263 15077711155 0014643 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::Password;
use strict;
use base qw(Debconf::Element::Noninteractive);
1
Debconf/Element/Noninteractive/Multiselect.pm 0000666 00000000266 15077711155 0015336 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::Multiselect;
use strict;
use base qw(Debconf::Element::Noninteractive);
1
Debconf/Element/Noninteractive/Error.pm 0000666 00000002766 15077711155 0014144 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::Error;
use strict;
use Text::Wrap;
use Debconf::Gettext;
use Debconf::Config;
use Debconf::Log ':all';
use base qw(Debconf::Element::Noninteractive);
sub show {
my $this=shift;
if ($this->question->flag('seen') ne 'true') {
$this->sendmail(gettext("Debconf was not configured to display this error message, so it mailed it to you."));
}
$this->value('');
}
sub sendmail {
my $this=shift;
my $footer=shift;
return unless length Debconf::Config->admin_email;
if (-x '/usr/bin/mail') {
debug user => "mailing a note";
my $title=gettext("Debconf").": ".
$this->frontend->title." -- ".
$this->question->description;
unless (open(MAIL, "|-")) { # child
exec("mail", "-s", $title, Debconf::Config->admin_email) or return '';
}
my $old_columns=$Text::Wrap::columns;
$Text::Wrap::columns=75;
if ($this->question->extended_description ne '') {
print MAIL wrap('', '', $this->question->extended_description);
}
else {
print MAIL wrap('', '', $this->question->description);
}
print MAIL "\n\n";
my $hostname=`hostname -f 2>/dev/null`;
if (! defined $hostname) {
$hostname="unknown system";
}
print MAIL "-- \n", sprintf(gettext("Debconf, running at %s"), $hostname, "\n");
print MAIL "[ ", wrap('', '', $footer), " ]\n" if $footer;
close MAIL or return '';
$Text::Wrap::columns=$old_columns;
$this->question->flag('seen', 'true');
return 1;
}
}
1
Debconf/Element/Noninteractive/Select.pm 0000666 00000001132 15077711155 0014254 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::Select;
use strict;
use base qw(Debconf::Element::Noninteractive);
sub show {
my $this=shift;
$this->question->template->i18n('');
my @choices=$this->question->choices_split;
$this->question->template->i18n(1);
my $value=$this->question->value;
$value='' unless defined $value;
my $inlist=0;
map { $inlist=1 if $_ eq $value } @choices;
if (! $inlist) {
if (@choices) {
$this->value($choices[0]);
}
else {
$this->value('');
}
}
else {
$this->value($value);
}
}
1
Debconf/Element/Noninteractive/String.pm 0000666 00000000261 15077711155 0014305 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::String;
use strict;
use base qw(Debconf::Element::Noninteractive);
1
Debconf/Element/Noninteractive/Note.pm 0000666 00000000257 15077711155 0013751 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::Note;
use strict;
use base qw(Debconf::Element::Noninteractive);
1
Debconf/Element/Noninteractive/Text.pm 0000666 00000000342 15077711155 0013763 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::Text;
use strict;
use base qw(Debconf::Element::Noninteractive);
sub show {
my $this=shift;
$this->value('');
}
1
Debconf/Element/Noninteractive/Boolean.pm 0000666 00000000262 15077711155 0014417 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::Boolean;
use strict;
use base qw(Debconf::Element::Noninteractive);
1
Debconf/Element/Noninteractive/Progress.pm 0000666 00000000402 15077711155 0014640 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive::Progress;
use strict;
use base qw(Debconf::Element::Noninteractive);
sub start {
}
sub set {
return 1;
}
sub info {
return 1;
}
sub stop {
}
1;
Debconf/Element/Multiselect.pm 0000666 00000001624 15077711155 0012345 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Multiselect;
use strict;
use base qw(Debconf::Element::Select);
sub order_values {
my $this=shift;
my %vals=map { $_ => 1 } @_;
$this->question->template->i18n('');
my @ret=grep { $vals{$_} } $this->question->choices_split;
$this->question->template->i18n(1);
return @ret;
}
sub visible {
my $this=shift;
my @choices=$this->question->choices_split;
return ($#choices >= 0);
}
sub translate_default {
my $this=shift;
my @choices=$this->question->choices_split;
$this->question->template->i18n('');
my @choices_c=$this->question->choices_split;
$this->question->template->i18n(1);
my @ret;
foreach my $c_default ($this->question->value_split) {
foreach (my $x=0; $x <= $#choices; $x++) {
push @ret, $choices[$x]
if $choices_c[$x] eq $c_default;
}
}
return @ret;
}
1
Debconf/Element/Dialog/Password.pm 0000666 00000001262 15077711155 0013052 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::Password;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
my ($text, $lines, $columns)=
$this->frontend->makeprompt($this->question);
my @params=('--passwordbox');
push @params, $this->frontend->dashsep if $this->frontend->dashsep;
push @params, ($text, $lines + $this->frontend->spacer, $columns);
my $ret=$this->frontend->showdialog($this->question, @params);
if (! defined $ret || $ret eq '') {
my $default='';
$default=$this->question->value
if defined $this->question->value;
$this->value($default);
}
else {
$this->value($ret);
}
}
1
Debconf/Element/Dialog/Multiselect.pm 0000666 00000003450 15077711155 0013543 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::Multiselect;
use strict;
use base qw(Debconf::Element::Multiselect);
use Debconf::Encoding qw(width);
sub show {
my $this=shift;
my ($text, $lines, $columns)=
$this->frontend->makeprompt($this->question, -2);
my $screen_lines=$this->frontend->screenheight - $this->frontend->spacer;
my @params=();
my @choices=$this->question->choices_split;
my %value = map { $_ => 1 } $this->translate_default;
my $menu_height=$#choices + 1;
if ($lines + $#choices + 2 >= $screen_lines) {
$menu_height = $screen_lines - $lines - 4;
if ($menu_height < 3 && $#choices + 1 > 2) {
$this->frontend->showtext($this->question, $this->question->extended_description);
($text, $lines, $columns)=$this->frontend->sizetext($this->question->description);
$menu_height=$#choices + 1;
if ($lines + $#choices + 2 >= $screen_lines) {
$menu_height = $screen_lines - $lines - 4;
}
}
}
$lines=$lines + $menu_height + $this->frontend->spacer;
my $selectspacer = $this->frontend->selectspacer;
my $c=1;
foreach (@choices) {
push @params, ($_, "");
push @params, ($value{$_} ? 'on' : 'off');
if ($columns < width($_) + $selectspacer) {
$columns = width($_) + $selectspacer;
}
}
if ($this->frontend->dashsep) {
unshift @params, $this->frontend->dashsep;
}
@params=('--separate-output', '--checklist',
$text, $lines, $columns, $menu_height, @params);
my $value=$this->frontend->showdialog($this->question, @params);
if (defined $value) {
$this->value(join(", ", $this->order_values(
map { $this->translate_to_C($_) }
split(/\n/, $value))));
}
else {
my $default='';
$default=$this->question->value
if defined $this->question->value;
$this->value($default);
}
}
1
Debconf/Element/Dialog/Error.pm 0000666 00000000513 15077711155 0012337 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::Error;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->showtext($this->question,
$this->question->description."\n\n".
$this->question->extended_description
);
$this->value('');
}
1
Debconf/Element/Dialog/Select.pm 0000666 00000002506 15077711155 0012471 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::Select;
use strict;
use base qw(Debconf::Element::Select);
use Debconf::Encoding qw(width);
sub show {
my $this=shift;
my ($text, $lines, $columns)=
$this->frontend->makeprompt($this->question, -2);
my $screen_lines=$this->frontend->screenheight - $this->frontend->spacer;
my $default=$this->translate_default;
my @params=();
my @choices=$this->question->choices_split;
my $menu_height=$#choices + 1;
if ($lines + $#choices + 2 >= $screen_lines) {
$menu_height = $screen_lines - $lines - 4;
}
$lines=$lines + $menu_height + $this->frontend->spacer;
my $c=1;
my $selectspacer = $this->frontend->selectspacer;
foreach (@choices) {
push @params, $_, '';
if ($columns < width($_) + $selectspacer) {
$columns = width($_) + $selectspacer;
}
}
if ($this->frontend->dashsep) {
unshift @params, $this->frontend->dashsep;
}
@params=('--default-item', $default, '--menu',
$text, $lines, $columns, $menu_height, @params);
my $value=$this->frontend->showdialog($this->question, @params);
if (defined $value) {
$this->value($this->translate_to_C($value)) if defined $value;
}
else {
my $default='';
$default=$this->question->value
if defined $this->question->value;
$this->value($default);
}
}
1
Debconf/Element/Dialog/String.pm 0000666 00000001424 15077711155 0012516 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::String;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
my ($text, $lines, $columns)=
$this->frontend->makeprompt($this->question);
my $default='';
$default=$this->question->value if defined $this->question->value;
my @params=('--inputbox');
push @params, $this->frontend->dashsep if $this->frontend->dashsep;
push @params, ($text, $lines + $this->frontend->spacer,
$columns, $default);
my $value=$this->frontend->showdialog($this->question, @params);
if (defined $value) {
$this->value($value);
}
else {
my $default='';
$default=$this->question->value
if defined $this->question->value;
$this->value($default);
}
}
1
Debconf/Element/Dialog/Note.pm 0000666 00000000512 15077711155 0012152 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::Note;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->showtext($this->question,
$this->question->description."\n\n".
$this->question->extended_description
);
$this->value('');
}
1
Debconf/Element/Dialog/Text.pm 0000666 00000000512 15077711155 0012171 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::Text;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->showtext($this->question,
$this->question->description."\n\n".
$this->question->extended_description
);
$this->value('');
}
1
Debconf/Element/Dialog/Boolean.pm 0000666 00000001331 15077711155 0012624 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::Boolean;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
my @params=('--yesno');
push @params, $this->frontend->dashsep if $this->frontend->dashsep;
push @params, $this->frontend->makeprompt($this->question, 1);
if (defined $this->question->value && $this->question->value eq 'false') {
unshift @params, '--defaultno';
}
my ($ret, $value)=$this->frontend->showdialog($this->question, @params);
if (defined $ret) {
$this->value($ret eq 0 ? 'true' : 'false');
}
else {
my $default='';
$default=$this->question->value
if defined $this->question->value;
$this->value($default);
}
}
1
Debconf/Element/Dialog/Progress.pm 0000666 00000003466 15077711155 0013064 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Dialog::Progress;
use strict;
use base qw(Debconf::Element);
sub _communicate {
my $this=shift;
my $data=shift;
my $dialoginput = $this->frontend->dialog_input_wtr;
print $dialoginput $data;
}
sub _percent {
my $this=shift;
use integer;
return (($this->progress_cur() - $this->progress_min()) * 100 / ($this->progress_max() - $this->progress_min()));
}
sub start {
my $this=shift;
$this->frontend->title($this->question->description);
my ($text, $lines, $columns);
if (defined $this->_info) {
($text, $lines, $columns)=$this->frontend->sizetext($this->_info->description);
} else {
($text, $lines, $columns)=$this->frontend->sizetext(' ');
}
if ($this->frontend->screenwidth - $this->frontend->columnspacer > $columns) {
$columns = $this->frontend->screenwidth - $this->frontend->columnspacer;
}
my @params=('--gauge');
push @params, $this->frontend->dashsep if $this->frontend->dashsep;
push @params, ($text, $lines + $this->frontend->spacer, $columns, $this->_percent);
$this->frontend->startdialog($this->question, 1, @params);
$this->_lines($lines);
$this->_columns($columns);
}
sub set {
my $this=shift;
my $value=shift;
$this->progress_cur($value);
$this->_communicate($this->_percent . "\n");
return 1;
}
sub info {
my $this=shift;
my $question=shift;
$this->_info($question);
my ($text, $lines, $columns)=$this->frontend->sizetext($question->description);
if ($lines > $this->_lines or $columns > $this->_columns) {
$this->stop;
$this->start;
}
$this->_communicate(
sprintf("XXX\n%d\n%s\nXXX\n%d\n",
$this->_percent, $text, $this->_percent));
return 1;
}
sub stop {
my $this=shift;
$this->frontend->waitdialog;
$this->frontend->title($this->frontend->requested_title);
}
1
Debconf/Element/Web/Password.pm 0000666 00000000743 15077711155 0012373 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Web::Password;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$_=$this->question->extended_description;
s/\n/\n\n";
my $default='';
$default=$this->question->value if defined $this->question->value;
my $id=$this->id;
$_.="".$this->question->description."
\n";
my %value = map { $_ => 1 } $this->translate_default;
my $id=$this->id;
$_.="".$this->question->description." \n\n";
my $c=0;
foreach my $x ($this->question->choices_split) {
if (! $value{$x}) {
$_.="$x\n";
}
else {
$_.=" $x\n";
}
}
$_.=" \n";
return $_;
}
sub value {
my $this=shift;
return $this->SUPER::value() unless @_;
my @values=@_;
$this->question->template->i18n('');
my @choices=$this->question->choices_split;
$this->question->template->i18n(1);
$this->SUPER::value(join(', ', $this->order_values(map { $choices[$_] } @values)));
}
1
Debconf/Element/Web/Error.pm 0000666 00000000240 15077711155 0011652 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Web::Error;
use strict;
use base qw(Debconf::Element::Web::Text);
1
Debconf/Element/Web/Select.pm 0000666 00000001555 15077711155 0012012 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Web::Select;
use strict;
use base qw(Debconf::Element::Select);
sub show {
my $this=shift;
$_=$this->question->extended_description;
s/\n/\n
\n";
my $default=$this->translate_default;
my $id=$this->id;
$_.="".$this->question->description." \n\n";
my $c=0;
foreach my $x ($this->question->choices_split) {
if ($x ne $default) {
$_.="$x\n";
}
else {
$_.=" $x\n";
}
}
$_.=" \n";
return $_;
}
sub value {
my $this=shift;
return $this->SUPER::value() unless @_;
my $value=shift;
$this->question->template->i18n('');
my @choices=$this->question->choices_split;
$this->question->template->i18n(1);
$this->SUPER::value($choices[$value]);
}
1
Debconf/Element/Web/String.pm 0000666 00000000723 15077711155 0012035 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Web::String;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$_=$this->question->extended_description;
s/\n/\n
\n";
my $default='';
$default=$this->question->value if defined $this->question->value;
my $id=$this->id;
$_.="".$this->question->description."
\n";
return "".$this->question->description." $_
";
}
1
Debconf/Element/Web/Boolean.pm 0000666 00000001224 15077711155 0012143 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Web::Boolean;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$_=$this->question->extended_description;
s/\n/\n
\n";
my $default='';
$default=$this->question->value if defined $this->question->value;
my $id=$this->id;
$_.="".
$this->question->description." ";
return $_;
}
sub value {
my $this=shift;
return $this->SUPER::value() unless @_;
my $value=shift;
$this->SUPER::value($value eq 'on' ? 'true' : 'false');
}
1
Debconf/Element/Web/Progress.pm 0000666 00000000347 15077711155 0012375 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Web::Progress;
use strict;
use base qw(Debconf::Element);
sub start {
}
sub set {
return 1;
}
sub info {
return 1;
}
sub stop {
}
1;
Debconf/Element/Gnome.pm 0000666 00000005614 15077711155 0011123 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome;
use strict;
use utf8;
use Gtk2;
use Debconf::Gettext;
use Debconf::Encoding qw(to_Unicode);
use base qw(Debconf::Element);
sub init {
my $this=shift;
$this->hbox(Gtk2::VBox->new(0, 10));
$this->hline1(Gtk2::HBox->new(0, 10));
$this->hline1->show;
$this->line1(Gtk2::VBox->new(0, 10));
$this->line1->show;
$this->line1->pack_end ($this->hline1, 1, 1, 0);
$this->hline2(Gtk2::HBox->new(0, 10));
$this->hline2->show;
$this->line2(Gtk2::VBox->new(0, 10));
$this->line2->show;
$this->line2->pack_end ($this->hline2, 1, 1, 0);
$this->vbox(Gtk2::VBox->new(0, 5));
$this->vbox->pack_start($this->line1, 0, 0, 0);
$this->vbox->pack_start($this->line2, 1, 1, 0);
$this->vbox->show;
$this->hbox->pack_start($this->vbox, 1, 1, 0);
$this->hbox->show;
$this->fill(0);
$this->expand(0);
$this->multiline(0);
}
sub addwidget {
my $this=shift;
my $widget=shift;
if ($this->multiline == 0) {
$this->hline1->pack_start($widget, 1, 1, 0);
}
else {
$this->hline2->pack_start($widget, 1, 1, 0);
}
}
sub adddescription {
my $this=shift;
my $description=to_Unicode($this->question->description);
my $label=Gtk2::Label->new($description);
$label->show;
$this->line1->pack_start($label, 0, 0, 0);
}
sub addbutton {
my $this=shift;
my $text = shift;
my $callback = shift;
my $button = Gtk2::Button->new_with_mnemonic(to_Unicode($text));
$button->show;
$button->signal_connect("clicked", $callback);
my $vbox = Gtk2::VBox->new(0, 0);
$vbox->show;
$vbox->pack_start($button, 1, 0, 0);
$this->hline1->pack_end($vbox, 0, 0, 0);
}
sub create_message_dialog {
my $this = shift;
my $type = shift;
my $title = shift;
my $text = shift;
my $dialog =
Gtk2::Dialog->new_with_buttons(to_Unicode($title), undef,
"modal", "gtk-close", "close");
$dialog->set_border_width(3);
my $hbox = Gtk2::HBox->new(0);
$dialog->vbox->pack_start($hbox, 1, 1, 5);
$hbox->show;
my $alignment = Gtk2::Alignment->new(0.5, 0.0, 1.0, 0.0);
$hbox->pack_start($alignment, 1, 1, 3);
$alignment->show;
my $image = Gtk2::Image->new_from_stock($type, "dialog");
$alignment->add($image);
$image->show;
my $label = Gtk2::Label->new(to_Unicode($text));
$label->set_line_wrap(1);
$hbox->pack_start($label, 1, 1, 2);
$label->show;
$dialog->run;
$dialog->destroy;
}
sub addhelp {
my $this=shift;
my $help=$this->question->extended_description;
return unless length $help;
$this->addbutton(gettext("_Help"), sub {
$this->create_message_dialog("gtk-dialog-info",
gettext("Help"),
to_Unicode($help));
});
if (defined $this->tip ){
$this->tooltips( Gtk2::Tooltips->new() );
$this->tooltips->set_tip($this->tip, to_Unicode($help),
undef );
$this->tooltips->enable;
}
}
sub value {
my $this=shift;
return '';
}
1
Debconf/Element/Select.pm 0000666 00000003676 15077711155 0011303 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Select;
use strict;
use Debconf::Log ':all';
use Debconf::Gettext;
use base qw(Debconf::Element);
use Debconf::Encoding qw(to_Unicode);
sub visible {
my $this=shift;
my @choices=$this->question->choices_split;
if (@choices > 1) {
return 1;
}
else {
debug 'developer' => 'Not displaying select list '.
$this->question->name.' with '.
(@choices+0).' choice'.((@choices == 0) ? 's' : '');
return 0;
}
}
sub translate_default {
my $this=shift;
my @choices=$this->question->choices_split;
$this->question->template->i18n('');
my @choices_c=$this->question->choices_split;
$this->question->template->i18n(1);
my $c_default='';
$c_default=$this->question->value if defined $this->question->value;
foreach (my $x=0; $x <= $#choices; $x++) {
return $choices[$x] if $choices_c[$x] eq $c_default;
}
return '';
}
sub translate_to_C {
my $this=shift;
my $value=shift;
my @choices=$this->question->choices_split;
$this->question->template->i18n('');
my @choices_c=$this->question->choices_split;
$this->question->template->i18n(1);
for (my $x=0; $x <= $#choices; $x++) {
return $choices_c[$x] if $choices[$x] eq $value;
}
debug developer => sprintf(gettext("Input value, \"%s\" not found in C choices! This should never happen. Perhaps the templates were incorrectly localized."), $value);
return '';
}
sub translate_to_C_uni {
my $this=shift;
my $value=shift;
my @choices=$this->question->choices_split;
$this->question->template->i18n('');
my @choices_c=$this->question->choices_split;
$this->question->template->i18n(1);
for (my $x=0; $x <= $#choices; $x++) {
return $choices_c[$x] if to_Unicode($choices[$x]) eq $value;
}
debug developer => sprintf(gettext("Input value, \"%s\" not found in C choices! This should never happen. Perhaps the templates were incorrectly localized."), $value);
return '';
}
1
Debconf/Element/Teletype/Password.pm 0000666 00000001165 15077711155 0013450 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::Password;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->display(
$this->question->extended_description."\n");
my $default='';
$default=$this->question->value if defined $this->question->value;
my $value=$this->frontend->prompt_password(
prompt => $this->question->description,
default => $default,
question => $this->question,
);
return unless defined $value;
if ($value eq '') {
$value=$default;
}
$this->frontend->display("\n");
$this->value($value);
}
1
Debconf/Element/Teletype/Multiselect.pm 0000666 00000003553 15077711155 0014143 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::Multiselect;
use strict;
use Debconf::Gettext;
use Debconf::Config;
use base qw(Debconf::Element::Multiselect Debconf::Element::Teletype::Select);
sub show {
my $this=shift;
my @selected;
my $none_of_the_above=gettext("none of the above");
my @choices=$this->question->choices_split;
my %value = map { $_ => 1 } $this->translate_default;
if ($this->frontend->promptdefault && $this->question->value ne '') {
push @choices, $none_of_the_above;
}
my @completions=@choices;
my $i=1;
my %choicenum=map { $_ => $i++ } @choices;
$this->frontend->display($this->question->extended_description."\n");
my $default;
if (Debconf::Config->terse eq 'false') {
$this->printlist(@choices);
$this->frontend->display("\n(".gettext("Enter the items you want to select, separated by spaces.").")\n");
push @completions, 1..@choices;
$default=join(" ", map { $choicenum{$_} }
grep { $value{$_} } @choices);
}
else {
$default=join(" ", grep { $value{$_} } @choices);
}
while (1) {
$_=$this->frontend->prompt(
prompt => $this->question->description,
default => $default,
completions => [@completions],
completion_append_character => " ",
question => $this->question,
);
return unless defined $_;
@selected=split(/[ ,]+/, $_);
@selected=map { $this->expandabbrev($_, @choices) } @selected;
next if grep { $_ eq '' } @selected;
if ($#selected > 0) {
map { next if $_ eq $none_of_the_above } @selected;
}
last;
}
$this->frontend->display("\n");
if (defined $selected[0] && $selected[0] eq $none_of_the_above) {
$this->value('');
}
else {
my %selected=map { $_ => 1 } @selected;
$this->value(join(', ', $this->order_values(
map { $this->translate_to_C($_) }
keys %selected)));
}
}
1
Debconf/Element/Teletype/Error.pm 0000666 00000000252 15077711155 0012733 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::Error;
use strict;
use base qw(Debconf::Element::Teletype::Text);
1
Debconf/Element/Teletype/Select.pm 0000666 00000006314 15077711155 0013066 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::Select;
use strict;
use Debconf::Config;
use POSIX qw(ceil);
use base qw(Debconf::Element::Select);
sub expandabbrev {
my $this=shift;
my $input=shift;
my @choices=@_;
if (Debconf::Config->terse eq 'false' and
$input=~m/^[0-9]+$/ and $input ne '0' and $input <= @choices) {
return $choices[$input - 1];
}
my @matches=();
foreach (@choices) {
return $_ if /^\Q$input\E$/;
push @matches, $_ if /^\Q$input\E/;
}
return $matches[0] if @matches == 1;
if (! @matches) {
foreach (@choices) {
return $_ if /^\Q$input\E$/i;
push @matches, $_ if /^\Q$input\E/i;
}
return $matches[0] if @matches == 1;
}
return '';
}
sub printlist {
my $this=shift;
my @choices=@_;
my $width=$this->frontend->screenwidth;
my $choice_min=length $choices[0];
map { $choice_min = length $_ if length $_ < $choice_min } @choices;
my $max_cols=int($width / (2 + length(@choices) + 2 + $choice_min)) - 1;
$max_cols = $#choices if $max_cols > $#choices;
my $max_lines;
my $num_cols;
COLUMN: for ($num_cols = $max_cols; $num_cols >= 0; $num_cols--) {
my @col_width;
my $total_width;
$max_lines=ceil(($#choices + 1) / ($num_cols + 1));
next if ceil(($#choices + 1) / $max_lines) - 1 < $num_cols;
foreach (my $choice=1; $choice <= $#choices + 1; $choice++) {
my $choice_length=2
+ length(@choices) + 2
+ length($choices[$choice - 1]);
my $current_col=ceil($choice / $max_lines) - 1;
if (! defined $col_width[$current_col] ||
$choice_length > $col_width[$current_col]) {
$col_width[$current_col]=$choice_length;
$total_width=0;
map { $total_width += $_ } @col_width;
next COLUMN if $total_width > $width;
}
}
last;
}
my $line=0;
my $max_len=0;
my $col=0;
my @output=();
for (my $choice=0; $choice <= $#choices; $choice++) {
$output[$line] .= " ".($choice+1).". " . $choices[$choice];
if (length $output[$line] > $max_len) {
$max_len = length $output[$line];
}
if (++$line >= $max_lines) {
if ($col++ != $num_cols) {
for (my $l=0; $l <= $#output; $l++) {
$output[$l] .= ' ' x ($max_len - length $output[$l]);
}
}
$line=0;
$max_len=0;
}
}
@output = map { s/\s+$//; $_ } @output;
map { $this->frontend->display_nowrap($_) } @output;
}
sub show {
my $this=shift;
my $default=$this->translate_default;
my @choices=$this->question->choices_split;
my @completions=@choices;
$this->frontend->display($this->question->extended_description."\n");
if (Debconf::Config->terse eq 'false') {
for (my $choice=0; $choice <= $#choices; $choice++) {
if ($choices[$choice] eq $default) {
$default=$choice + 1;
last;
}
}
$this->printlist(@choices);
$this->frontend->display("\n");
push @completions, 1..@choices;
}
my $value;
while (1) {
$value=$this->frontend->prompt(
prompt => $this->question->description,
default => $default ? $default : '',
completions => [@completions],
question => $this->question,
);
return unless defined $value;
$value=$this->expandabbrev($value, @choices);
last if $value ne '';
}
$this->frontend->display("\n");
$this->value($this->translate_to_C($value));
}
1
Debconf/Element/Teletype/String.pm 0000666 00000001075 15077711155 0013114 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::String;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->display(
$this->question->extended_description."\n");
my $default='';
$default=$this->question->value if defined $this->question->value;
my $value=$this->frontend->prompt(
prompt => $this->question->description,
default => $default,
question => $this->question,
);
return unless defined $value;
$this->frontend->display("\n");
$this->value($value);
}
1
Debconf/Element/Teletype/Note.pm 0000666 00000000623 15077711155 0012551 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::Note;
use strict;
use base qw(Debconf::Element);
sub visible {
my $this=shift;
return (Debconf::Config->terse eq 'false');
}
sub show {
my $this=shift;
$this->frontend->display($this->question->description."\n\n".
$this->question->extended_description."\n");
$this->value('');
}
1
Debconf/Element/Teletype/Text.pm 0000666 00000000473 15077711155 0012573 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::Text;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->display($this->question->description."\n\n".
$this->question->extended_description."\n");
$this->value('');
}
1
Debconf/Element/Teletype/Boolean.pm 0000666 00000002103 15077711155 0013216 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::Boolean;
use strict;
use Debconf::Gettext;
use base qw(Debconf::Element);
sub show {
my $this=shift;
my $y=gettext("yes");
my $n=gettext("no");
$this->frontend->display($this->question->extended_description."\n");
my $default='';
$default=$this->question->value if defined $this->question->value;
if ($default eq 'true') {
$default=$y;
}
elsif ($default eq 'false') {
$default=$n;
}
my $value='';
while (1) {
$_=$this->frontend->prompt(
default => $default,
completions => [$y, $n],
prompt => $this->question->description,
question => $this->question,
);
return unless defined $_;
if (substr($y, 0, 1) ne substr($n, 0, 1)) {
$y=substr($y, 0, 1);
$n=substr($n, 0, 1);
}
if (/^\Q$y\E/i) {
$value='true';
last;
}
elsif (/^\Q$n\E/i) {
$value='false';
last;
}
if (/^y/i) {
$value='true';
last;
}
elsif (/^n/i) {
$value='false';
last;
}
}
$this->frontend->display("\n");
$this->value($value);
}
1
Debconf/Element/Teletype/Progress.pm 0000666 00000001445 15077711155 0013453 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Teletype::Progress;
use strict;
use base qw(Debconf::Element);
sub start {
my $this=shift;
$this->frontend->title($this->question->description);
$this->frontend->display('');
$this->last(0);
}
sub set {
my $this=shift;
my $value=shift;
$this->progress_cur($value);
use integer;
my $new = ($this->progress_cur() - $this->progress_min()) * 100 / ($this->progress_max() - $this->progress_min());
$this->last(0) if $new < $this->last;
return if $new / 10 == $this->last / 10;
$this->last($new);
$this->frontend->display("..$new%");
return 1;
}
sub info {
return 1;
}
sub stop {
my $this=shift;
$this->frontend->display("\n");
$this->frontend->title($this->frontend->requested_title);
}
1;
Debconf/Element/Kde.pm 0000666 00000004211 15077711155 0010551 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Kde::ElementWidget;
use QtCore4;
use QtCore4::isa @ISA = qw(Qt::Widget);
use QtGui4;
sub NEW {
shift->SUPER::NEW ($_[0]);
this->{mytop} = undef;
}
sub settop {
this->{mytop} = shift;
}
sub init {
this->{toplayout} = Qt::VBoxLayout(this);
this->{mytop} = Qt::Widget(this);
this->{toplayout}->addWidget (this->{mytop});
this->{layout} = Qt::VBoxLayout();
this->{mytop}->setLayout(this->{layout});
}
sub destroy {
this->{toplayout} -> removeWidget (this->{mytop});
undef this->{mytop};
}
sub top {
return this->{mytop};
}
sub addwidget {
this->{layout}->addWidget(@_);
}
sub addlayout {
this->{layout}->addLayout (@_);
}
package Debconf::Element::Kde;
use strict;
use QtCore4;
use QtGui4;
use Debconf::Gettext;
use base qw(Debconf::Element);
use Debconf::Element::Kde::ElementWidget;
use Debconf::Encoding qw(to_Unicode);
sub create {
my $this=shift;
$this->parent(shift);
$this->top(Debconf::Element::Kde::ElementWidget($this->parent, undef,
undef, undef));
$this->top->init;
$this->top->show;
}
sub destroy {
my $this=shift;
$this->top(undef);
}
sub addwidget {
my $this=shift;
my $widget=shift;
$this->cur->addwidget($widget);
}
sub description {
my $this=shift;
my $label=Qt::Label($this->cur->top);
$label->setText("".to_Unicode($this->question->description." "));
$label->show;
return $label;
}
sub startsect {
my $this = shift;
my $ew = Debconf::Element::Kde::ElementWidget($this->top);
$ew->init;
$this->cur($ew);
$this->top->addwidget($ew);
$ew->show;
}
sub endsect {
my $this = shift;
$this->cur($this->top);
}
sub adddescription {
my $this=shift;
my $label=$this->description;
$this->addwidget($label);
}
sub addhelp {
my $this=shift;
my $help=to_Unicode($this->question->extended_description);
return unless length $help;
my $label=Qt::Label($this->cur->top);
$label->setText($help);
$label->setWordWrap(1);
$this->addwidget($label); # line1
$label->setMargin(5);
$label->show;
}
sub value {
my $this=shift;
return '';
}
1
Debconf/Element/Noninteractive.pm 0000666 00000000526 15077711155 0013043 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Noninteractive;
use strict;
use base qw(Debconf::Element);
sub visible {
my $this=shift;
return;
}
sub show {
my $this=shift;
my $default='';
$default=$this->question->value if defined $this->question->value;
$this->value($default);
}
1
Debconf/Element/Editor/Password.pm 0000666 00000000253 15077711155 0013100 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::Password;
use strict;
use base qw(Debconf::Element::Editor::String);
1
Debconf/Element/Editor/Multiselect.pm 0000666 00000001624 15077711155 0013573 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::Multiselect;
use strict;
use Debconf::Gettext;
use base qw(Debconf::Element::Multiselect);
sub show {
my $this=shift;
my @choices=$this->question->choices_split;
$this->frontend->comment($this->question->extended_description."\n\n".
"(".gettext("Choices").": ".join(", ", @choices).")\n".
gettext("(Enter zero or more items separated by a comma followed by a space (', ').)")."\n".
$this->question->description."\n");
$this->frontend->item($this->question->name, join ", ", $this->translate_default);
}
sub value {
my $this=shift;
return $this->SUPER::value() unless @_;
my @values=split(',\s+', shift);
my %valid=map { $_ => 1 } $this->question->choices_split;
$this->SUPER::value(join(', ', $this->order_values(
map { $this->translate_to_C($_) }
grep { $valid{$_} } @values)));
}
1
Debconf/Element/Editor/Error.pm 0000666 00000000245 15077711155 0012370 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::Error;
use strict;
use base qw(Debconf::Element::Editor::Text);
1
Debconf/Element/Editor/Select.pm 0000666 00000001502 15077711155 0012513 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::Select;
use strict;
use Debconf::Gettext;
use base qw(Debconf::Element::Select);
sub show {
my $this=shift;
my $default=$this->translate_default;
my @choices=$this->question->choices_split;
$this->frontend->comment($this->question->extended_description."\n\n".
"(".gettext("Choices").": ".join(", ", @choices).")\n".
$this->question->description."\n");
$this->frontend->item($this->question->name, $default);
}
sub value {
my $this=shift;
return $this->SUPER::value() unless @_;
my $value=shift;
my %valid=map { $_ => 1 } $this->question->choices_split;
if ($valid{$value}) {
return $this->SUPER::value($this->translate_to_C($value));
}
else {
return $this->SUPER::value($this->question->value);
}
}
1
Debconf/Element/Editor/String.pm 0000666 00000000667 15077711155 0012555 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::String;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->comment($this->question->extended_description."\n\n".
$this->question->description."\n");
my $default='';
$default=$this->question->value if defined $this->question->value;
$this->frontend->item($this->question->name, $default);
}
1
Debconf/Element/Editor/Note.pm 0000666 00000000244 15077711155 0012203 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::Note;
use strict;
use base qw(Debconf::Element::Editor::Text);
1
Debconf/Element/Editor/Text.pm 0000666 00000000474 15077711155 0012227 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::Text;
use strict;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->comment($this->question->extended_description."\n\n".
$this->question->description."\n\n");
$this->value('');
}
1
Debconf/Element/Editor/Boolean.pm 0000666 00000001761 15077711155 0012662 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::Boolean;
use strict;
use Debconf::Gettext;
use base qw(Debconf::Element);
sub show {
my $this=shift;
$this->frontend->comment($this->question->extended_description."\n\n".
"(".gettext("Choices").": ".join(", ", gettext("yes"), gettext("no")).")\n".
$this->question->description."\n");
my $default='';
$default=$this->question->value if defined $this->question->value;
if ($default eq 'true') {
$default=gettext("yes");
}
elsif ($default eq 'false') {
$default=gettext("no");
}
$this->frontend->item($this->question->name, $default);
}
sub value {
my $this=shift;
return $this->SUPER::value() unless @_;
my $value=shift;
if ($value eq 'yes' || $value eq gettext("yes")) {
return $this->SUPER::value('true');
}
elsif ($value eq 'no' || $value eq gettext("no")) {
return $this->SUPER::value('false');
}
else {
return $this->SUPER::value($this->question->value);
}
}
1
Debconf/Element/Editor/Progress.pm 0000666 00000000353 15077711155 0013103 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Editor::Progress;
use strict;
use base qw(Debconf::Element);
sub start {
}
sub set {
return 1;
}
sub info {
return 1;
}
sub stop {
}
1;
Debconf/Element/Gnome/Password.pm 0000666 00000001104 15077711155 0012713 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::Password;
use strict;
use Gtk2;
use utf8;
use base qw(Debconf::Element::Gnome);
sub init {
my $this=shift;
$this->SUPER::init(@_);
$this->adddescription;
$this->widget(Gtk2::Entry->new);
$this->widget->show;
$this->widget->set_visibility(0);
$this->addwidget($this->widget);
$this->tip( $this->widget );
$this->addhelp;
}
sub value {
my $this=shift;
my $text = $this->widget->get_chars(0, -1);
$text = $this->question->value if $text eq '';
return $text;
}
1
Debconf/Element/Gnome/Multiselect.pm 0000666 00000004657 15077711155 0013423 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::Multiselect;
use strict;
use Gtk2;
use utf8;
use Debconf::Encoding qw(to_Unicode);
use base qw(Debconf::Element::Gnome Debconf::Element::Multiselect);
use constant SELECTED_COLUMN => 0;
use constant CHOICES_COLUMN => 1;
sub init {
my $this=shift;
my @choices = map { to_Unicode($_) } $this->question->choices_split;
my %default=map { to_Unicode($_) => 1 } $this->translate_default;
$this->SUPER::init(@_);
$this->multiline(1);
$this->adddescription;
$this->widget(Gtk2::ScrolledWindow->new);
$this->widget->show;
$this->widget->set_policy('automatic', 'automatic');
my $list_store = Gtk2::ListStore->new('Glib::Boolean', 'Glib::String');
$this->list_view(Gtk2::TreeView->new($list_store));
$this->list_view->set_headers_visible(0);
my $renderer_toggle = Gtk2::CellRendererToggle->new;
$renderer_toggle->signal_connect(toggled => sub {
my $path_string = $_[1];
my $model = $_[2];
my $iter = $model->get_iter_from_string($path_string);
$model->set($iter, SELECTED_COLUMN,
not $model->get($iter, SELECTED_COLUMN));
}, $list_store);
$this->list_view->append_column(
Gtk2::TreeViewColumn->new_with_attributes('Selected',
$renderer_toggle, 'active', SELECTED_COLUMN));
$this->list_view->append_column(
Gtk2::TreeViewColumn->new_with_attributes('Choices',
Gtk2::CellRendererText->new, 'text', CHOICES_COLUMN));
$this->list_view->show;
$this->widget->add($this->list_view);
for (my $i=0; $i <= $#choices; $i++) {
my $iter = $list_store->append();
$list_store->set($iter, CHOICES_COLUMN, $choices[$i]);
if ($default{$choices[$i]}) {
$list_store->set($iter, SELECTED_COLUMN, 1);
}
}
$this->addwidget($this->widget);
$this->tip($this->list_view);
$this->addhelp;
$this->fill(1);
$this->expand(1);
}
sub value {
my $this=shift;
my $list_view = $this->list_view;
my $list_store = $list_view->get_model ();
my ($ret, $val);
my @vals;
$this->question->template->i18n('');
my @choices=$this->question->choices_split;
$this->question->template->i18n(1);
my $iter = $list_store->get_iter_first();
for (my $i=0; $i <= $#choices; $i++) {
if ($list_store->get($iter, SELECTED_COLUMN)) {
push @vals, $choices[$i];
}
$iter = $list_store->iter_next($iter);
}
return join(', ', $this->order_values(@vals));
}
*visible = \&Debconf::Element::Multiselect::visible;
1
Debconf/Element/Gnome/Error.pm 0000666 00000002216 15077711155 0012207 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::Error;
use strict;
use Debconf::Gettext;
use Gtk2;
use utf8;
use Debconf::Encoding qw(to_Unicode);
use base qw(Debconf::Element::Gnome);
sub init {
my $this=shift;
my $extended_description = to_Unicode($this->question->extended_description);
$this->SUPER::init(@_);
$this->multiline(1);
$this->fill(1);
$this->expand(1);
$this->widget(Gtk2::HBox->new(0, 0));
my $image = Gtk2::Image->new_from_stock("gtk-dialog-error", "dialog");
$image->show;
my $text = Gtk2::TextView->new();
my $textbuffer = $text->get_buffer;
$text->show;
$text->set_wrap_mode ("word");
$text->set_editable (0);
my $scrolled_window = Gtk2::ScrolledWindow->new();
$scrolled_window->show;
$scrolled_window->set_policy('automatic', 'automatic');
$scrolled_window->set_shadow_type('in');
$scrolled_window->add ($text);
$this->widget->show;
$this->widget->pack_start($image, 0, 0, 6);
$this->widget->pack_start($scrolled_window, 1, 1, 0);
$textbuffer->set_text($extended_description);
$this->widget->show;
$this->adddescription;
$this->addwidget($this->widget);
}
1
Debconf/Element/Gnome/Select.pm 0000666 00000002030 15077711155 0012327 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::Select;
use strict;
use Gtk2;
use Gnome2;
use utf8;
use Debconf::Encoding qw(to_Unicode);
use base qw(Debconf::Element::Gnome Debconf::Element::Select);
sub init {
my $this=shift;
my $default=$this->translate_default;
my @choices= map { to_Unicode($_) } $this->question->choices_split;
$this->SUPER::init(@_);
$this->widget(Gtk2::Combo->new);
$this->widget->show;
$this->widget->set_popdown_strings(@choices);
$this->widget->set_value_in_list(1, 0);
$this->widget->entry->set_editable(0);
if (defined($default) and length($default) != 0) {
$this->widget->entry->set_text(to_Unicode($default));
}
else {
$this->widget->entry->set_text($choices[0]);
}
$this->adddescription;
$this->addwidget($this->widget);
$this->tip( $this->widget->entry );
$this->addhelp;
}
sub value {
my $this=shift;
return $this->translate_to_C_uni($this->widget->entry->get_chars(0, -1));
}
*visible = \&Debconf::Element::Select::visible;
1
Debconf/Element/Gnome/String.pm 0000666 00000001211 15077711155 0012356 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::String;
use strict;
use Gtk2;
use utf8;
use Debconf::Encoding qw(to_Unicode);
use base qw(Debconf::Element::Gnome);
sub init {
my $this=shift;
$this->SUPER::init(@_);
$this->widget(Gtk2::Entry->new);
$this->widget->show;
my $default='';
$default=$this->question->value if defined $this->question->value;
$this->widget->set_text(to_Unicode($default));
$this->adddescription;
$this->addwidget($this->widget);
$this->tip( $this->widget );
$this->addhelp;
}
sub value {
my $this=shift;
return $this->widget->get_chars(0, -1);
}
1
Debconf/Element/Gnome/Note.pm 0000666 00000002064 15077711155 0012024 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::Note;
use strict;
use Debconf::Gettext;
use Gtk2;
use utf8;
use Debconf::Encoding qw(to_Unicode);
use Debconf::Element::Noninteractive::Note;
use base qw(Debconf::Element::Gnome);
sub init {
my $this=shift;
my $extended_description = to_Unicode($this->question->extended_description);
$this->SUPER::init(@_);
$this->multiline(1);
$this->fill(1);
$this->expand(1);
$this->widget(Gtk2::HBox->new(0, 0));
my $text = Gtk2::TextView->new();
my $textbuffer = $text->get_buffer;
$text->show;
$text->set_wrap_mode ("word");
$text->set_editable (0);
my $scrolled_window = Gtk2::ScrolledWindow->new();
$scrolled_window->show;
$scrolled_window->set_policy('automatic', 'automatic');
$scrolled_window->set_shadow_type('in');
$scrolled_window->add ($text);
$this->widget->show;
$this->widget->pack_start($scrolled_window, 1, 1, 0);
$textbuffer->set_text($extended_description);
$this->widget->show;
$this->adddescription;
$this->addwidget($this->widget);
}
1
Debconf/Element/Gnome/Text.pm 0000666 00000000454 15077711155 0012044 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::Text;
use strict;
use Debconf::Gettext;
use Gtk2;
use utf8;
use base qw(Debconf::Element::Gnome);
sub init {
my $this=shift;
$this->SUPER::init(@_);
$this->adddescription; # yeah, that's all
}
1
Debconf/Element/Gnome/Boolean.pm 0000666 00000001254 15077711155 0012476 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::Boolean;
use strict;
use Gtk2;
use utf8;
use Debconf::Encoding qw(to_Unicode);
use base qw(Debconf::Element::Gnome);
sub init {
my $this=shift;
my $description=to_Unicode($this->question->description);
$this->SUPER::init(@_);
$this->widget(Gtk2::CheckButton->new($description));
$this->widget->show;
$this->widget->set_active(($this->question->value eq 'true') ? 1 : 0);
$this->addwidget($this->widget);
$this->tip( $this->widget );
$this->addhelp;
}
sub value {
my $this=shift;
if ($this->widget->get_active) {
return "true";
}
else {
return "false";
}
}
1
Debconf/Element/Gnome/Progress.pm 0000666 00000002131 15077711155 0012716 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Element::Gnome::Progress;
use strict;
use Gtk2;
use utf8;
use Debconf::Encoding qw(to_Unicode);
use base qw(Debconf::Element::Gnome);
sub _fraction {
my $this=shift;
return (($this->progress_cur() - $this->progress_min()) / ($this->progress_max() - $this->progress_min()));
}
sub start {
my $this=shift;
my $description=to_Unicode($this->question->description);
my $frontend=$this->frontend;
$this->SUPER::init(@_);
$this->multiline(1);
$this->expand(1);
$frontend->title($description);
$this->widget(Gtk2::ProgressBar->new());
$this->widget->show;
$this->widget->set_text(' ');
$this->addwidget($this->widget);
$this->addhelp;
}
sub set {
my $this=shift;
my $value=shift;
$this->progress_cur($value);
$this->widget->set_fraction($this->_fraction);
return 1;
}
sub info {
my $this=shift;
my $question=shift;
$this->widget->set_text(to_Unicode($question->description));
return 1;
}
sub stop {
my $this=shift;
my $frontend=$this->frontend;
$frontend->title($frontend->requested_title);
}
1;
Debconf/Config.pm 0000666 00000015550 15077711155 0007672 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Config;
use strict;
use Debconf::Question;
use Debconf::Gettext;
use Debconf::Priority qw(priority_valid priority_list);
use Debconf::Log qw(warn);
use Debconf::Db;
use fields qw(config templates frontend frontend_forced priority terse reshow
admin_email log debug nowarnings smileys sigils
noninteractive_seen c_values);
our $config=fields::new('Debconf::Config');
our @config_files=("/etc/debconf.conf", "/usr/share/debconf/debconf.conf");
if ($ENV{DEBCONF_SYSTEMRC}) {
unshift @config_files, $ENV{DEBCONF_SYSTEMRC};
} else {
unshift @config_files, ((getpwuid($>))[7])."/.debconfrc";
}
sub _hashify ($$) {
my $text=shift;
my $hash=shift;
$text =~ s/\${([^}]+)}/$ENV{$1}/eg;
my %ret;
my $i;
foreach my $line (split /\n/, $text) {
next if $line=~/^\s*#/; # comment
next if $line=~/^\s*$/; # blank
$line=~s/^\s+//;
$line=~s/\s+$//;
$i++;
my ($key, $value)=split(/\s*:\s*/, $line, 2);
$key=~tr/-/_/;
die "Parse error" unless defined $key and length $key;
$hash->{lc($key)}=$value;
}
return $i;
}
sub _env_to_driver {
my $value=shift;
my ($name, $options) = $value =~ m/^(\w+)(?:{(.*)})?$/;
return unless $name;
return $name if Debconf::DbDriver->driver($name);
my %hash = @_; # defaults from params
$hash{driver} = $name;
if (defined $options) {
foreach (split ' ', $options) {
if (/^(\w+):(.*)/) {
$hash{$1}=$2;
}
else {
$hash{filename}=$_;
}
}
}
return Debconf::Db->makedriver(%hash)->{name};
}
sub load {
my $class=shift;
my $cf=shift;
my @defaults=@_;
if (! $cf) {
for my $file (@config_files) {
$cf=$file, last if -e $file;
}
}
die "No config file found" unless $cf;
open (DEBCONF_CONFIG, $cf) or die "$cf: $!\n";
local $/="\n\n"; # read a stanza at a time
1 until _hashify(, $config) || eof DEBCONF_CONFIG;
if (! exists $config->{config}) {
print STDERR "debconf: ".gettext("Config database not specified in config file.")."\n";
exit(1);
}
if (! exists $config->{templates}) {
print STDERR "debconf: ".gettext("Template database not specified in config file.")."\n";
exit(1);
}
if (exists $config->{sigils} || exists $config->{smileys}) {
print STDERR "debconf: ".gettext("The Sigils and Smileys options in the config file are no longer used. Please remove them.")."\n";
}
while () {
my %config=(@defaults);
if (exists $ENV{DEBCONF_DB_REPLACE}) {
$config{readonly} = "true";
}
next unless _hashify($_, \%config);
eval {
Debconf::Db->makedriver(%config);
};
if ($@) {
print STDERR "debconf: ".sprintf(gettext("Problem setting up the database defined by stanza %s of %s."),$., $cf)."\n";
die $@;
}
}
close DEBCONF_CONFIG;
if (exists $ENV{DEBCONF_DB_REPLACE}) {
$config->{config} = _env_to_driver($ENV{DEBCONF_DB_REPLACE},
name => "_ENV_REPLACE");
Debconf::Db->makedriver(
driver => "Pipe",
name => "_ENV_REPLACE_templates",
infd => "none",
outfd => "none",
);
my @template_stack = ("_ENV_REPLACE_templates", $config->{templates});
Debconf::Db->makedriver(
driver => "Stack",
name => "_ENV_stack_templates",
stack => join(", ", @template_stack),
);
$config->{templates} = "_ENV_stack_templates";
}
my @finalstack = ($config->{config});
if (exists $ENV{DEBCONF_DB_OVERRIDE}) {
unshift @finalstack, _env_to_driver($ENV{DEBCONF_DB_OVERRIDE},
name => "_ENV_OVERRIDE");
}
if (exists $ENV{DEBCONF_DB_FALLBACK}) {
push @finalstack, _env_to_driver($ENV{DEBCONF_DB_FALLBACK},
name => "_ENV_FALLBACK",
readonly => "true");
}
if (@finalstack > 1) {
Debconf::Db->makedriver(
driver => "Stack",
name => "_ENV_stack",
stack => join(", ", @finalstack),
);
$config->{config} = "_ENV_stack";
}
}
sub getopt {
my $class=shift;
my $usage=shift;
my $showusage=sub { # closure
print STDERR $usage."\n";
print STDERR gettext(<frontend(shift); $config->frontend_forced(1) },
'priority|p=s', sub { shift; $class->priority(shift) },
'terse', sub { $config->{terse} = 'true' },
'help|h', $showusage,
@_,
) || $showusage->();
}
sub frontend {
my $class=shift;
return $ENV{DEBIAN_FRONTEND} if exists $ENV{DEBIAN_FRONTEND};
$config->{frontend}=shift if @_;
return $config->{frontend} if exists $config->{frontend};
my $ret='dialog';
my $question=Debconf::Question->get('debconf/frontend');
if ($question) {
$ret=lcfirst($question->value) || $ret;
}
return $ret;
}
sub frontend_forced {
my ($class, $val) = @_;
$config->{frontend_forced} = $val
if defined $val || exists $ENV{DEBIAN_FRONTEND};
return $config->{frontend_forced} ? 1 : 0;
}
sub priority {
my $class=shift;
return $ENV{DEBIAN_PRIORITY} if exists $ENV{DEBIAN_PRIORITY};
if (@_) {
my $newpri=shift;
if (! priority_valid($newpri)) {
warn(sprintf(gettext("Ignoring invalid priority \"%s\""), $newpri));
warn(sprintf(gettext("Valid priorities are: %s"), join(" ", priority_list)));
}
else {
$config->{priority}=$newpri;
}
}
return $config->{priority} if exists $config->{priority};
my $ret='high';
my $question=Debconf::Question->get('debconf/priority');
if ($question) {
$ret=$question->value || $ret;
}
return $ret;
}
sub terse {
my $class=shift;
return $ENV{DEBCONF_TERSE} if exists $ENV{DEBCONF_TERSE};
$config->{terse}=$_[0] if @_;
return $config->{terse} if exists $config->{terse};
return 'false';
}
sub nowarnings {
my $class=shift;
return $ENV{DEBCONF_NOWARNINGS} if exists $ENV{DEBCONF_NOWARNINGS};
$config->{nowarnings}=$_[0] if @_;
return $config->{nowarnings} if exists $config->{nowarnings};
return 'false';
}
sub debug {
my $class=shift;
return $ENV{DEBCONF_DEBUG} if exists $ENV{DEBCONF_DEBUG};
return $config->{debug} if exists $config->{debug};
return '';
}
sub admin_email {
my $class=shift;
return $ENV{DEBCONF_ADMIN_EMAIL} if exists $ENV{DEBCONF_ADMIN_EMAIL};
return $config->{admin_email} if exists $config->{admin_email};
return 'root';
}
sub noninteractive_seen {
my $class=shift;
return $ENV{DEBCONF_NONINTERACTIVE_SEEN} if exists $ENV{DEBCONF_NONINTERACTIVE_SEEN};
return $config->{noninteractive_seen} if exists $config->{noninteractive_seen};
return 'false';
}
sub c_values {
my $class=shift;
return $ENV{DEBCONF_C_VALUES} if exists $ENV{DEBCONF_C_VALUES};
return $config->{c_values} if exists $config->{c_values};
return 'false';
}
sub AUTOLOAD {
(my $field = our $AUTOLOAD) =~ s/.*://;
my $class=shift;
return $config->{$field}=shift if @_;
return $config->{$field} if defined $config->{$field};
return '';
}
1
Debconf/AutoSelect.pm 0000666 00000003451 15077711155 0010532 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::AutoSelect;
use strict;
use Debconf::Gettext;
use Debconf::ConfModule;
use Debconf::Config;
use Debconf::Log qw(:all);
use base qw(Exporter);
our @EXPORT_OK = qw(make_frontend make_confmodule);
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
my %fallback=(
'Kde' => ['Dialog', 'Readline', 'Teletype'],
'Gnome' => ['Dialog', 'Readline', 'Teletype'],
'Web' => ['Dialog', 'Readline', 'Teletype'],
'Dialog' => ['Readline', 'Teletype'],
'Gtk' => ['Dialog', 'Readline', 'Teletype'],
'Readline' => ['Teletype', 'Dialog'],
'Editor' => ['Readline', 'Teletype'],
'Slang' => ['Dialog', 'Readline', 'Teletype'],
'Text' => ['Readline', 'Teletype', 'Dialog'],
);
my $frontend;
my $type;
sub make_frontend {
my $script=shift;
my $starttype=ucfirst($type) if defined $type;
if (! defined $starttype || ! length $starttype) {
$starttype = Debconf::Config->frontend;
if ($starttype =~ /^[A-Z]/) {
warn "Please do not capitalize the first letter of the debconf frontend.";
}
$starttype=ucfirst($starttype);
}
my $showfallback=0;
foreach $type ($starttype, @{$fallback{$starttype}}, 'Noninteractive') {
if (! $showfallback) {
debug user => "trying frontend $type";
}
else {
warn(sprintf(gettext("falling back to frontend: %s"), $type));
}
$frontend=eval qq{
use Debconf::FrontEnd::$type;
Debconf::FrontEnd::$type->new();
};
return $frontend if defined $frontend;
warn sprintf(gettext("unable to initialize frontend: %s"), $type);
$@=~s/\n.*//s;
warn "($@)";
$showfallback=1;
}
die sprintf(gettext("Unable to start a frontend: %s"), $@);
}
sub make_confmodule {
my $confmodule=Debconf::ConfModule->new(frontend => $frontend);
$confmodule->startup(@_) if @_;
return $confmodule;
}
1
Debconf/Client/ConfModule.pm 0000666 00000007474 15077711155 0011744 0 ustar 00 #!/usr/bin/perl -w
=head1 NAME
Debconf::Client::ConfModule - client module for ConfModules
=head1 SYNOPSIS
use Debconf::Client::ConfModule ':all';
version('2.0');
my $capb=capb('backup');
input("medium", "foo/bar");
my @ret=go();
if ($ret[0] == 30) {
# Back button pressed.
...
}
...
=head1 DESCRIPTION
This is a module to ease writing ConfModules for Debian's configuration
management system. It can communicate with a FrontEnd via the debconf
protocol (which is documented in full in the debconf_specification in
Debian policy).
The design is that each command in the protocol is represented by one
function in this module (with the name lower-cased). Call the function and
pass in any parameters you want to follow the command. If the function is
called in scalar context, it will return any textual return code. If it is
called in list context, an array consisting of the numeric return code and
the textual return code will be returned.
This module uses Exporter to export all functions it defines. To import
everything, simply import ":all".
=over 4
=cut
package Debconf::Client::ConfModule;
use strict;
use base qw(Exporter);
# List all valid commands here.
our @EXPORT_OK=qw(version capb stop reset title input beginblock endblock go
unset set get register unregister clear previous_module
start_frontend fset fget subst purge metaget visible exist
settitle info progress data x_loadtemplatefile);
# Import :all to get everything.
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
# Set up valid command lookup hash.
my %commands;
map { $commands{uc $_}=1; } @EXPORT_OK;
# Unbuffered output is required.
$|=1;
=item import
Ensure that a FrontEnd is running. It's a little hackish. If
DEBIAN_HAS_FRONTEND is set, a FrontEnd is assumed to be running.
If not, one is started up automatically and stdin and out are
connected to it. Note that this function is always run when the
module is loaded in the usual way.
=cut
sub import {
if (! $ENV{DEBIAN_HAS_FRONTEND}) {
$ENV{PERL_DL_NONLAZY}=1;
if (exists $ENV{DEBCONF_USE_CDEBCONF} and
$ENV{DEBCONF_USE_CDEBCONF} ne '') {
exec "/usr/lib/cdebconf/debconf", $0, @ARGV;
} else {
exec "/usr/share/debconf/frontend", $0, @ARGV;
}
}
# Make the Exporter still work.
Debconf::Client::ConfModule->export_to_level(1, @_);
# A truly gross hack. This is only needed if
# /usr/share/debconf/confmodule is loaded, and then this
# perl module is used. In that case, this module needs to write
# to fd #3, rather than stdout. See changelog 0.3.74.
if (exists $ENV{DEBCONF_REDIR} && $ENV{DEBCONF_REDIR}) {
open(STDOUT,">&3");
}
}
=item stop
The frontend doesn't send a return code here, so we cannot try to read it
or we'll block.
=cut
sub stop {
print "STOP\n";
return;
}
=item AUTOLOAD
Creates handler functions for commands on the fly.
=cut
sub AUTOLOAD {
my $command = uc our $AUTOLOAD;
$command =~ s|.*:||; # strip fully-qualified portion
die "Unsupported command `$command'."
unless $commands{$command};
no strict 'refs';
*$AUTOLOAD = sub {
my $c=join (' ', $command, @_);
# Newlines in input can really badly confuse the protocol, so
# detect and warn.
if ($c=~m/\n/) {
warn "Warning: Newline present in parameters passed to debconf.\n";
warn "This will probably cause strange things to happen!\n";
}
print "$c\n";
my $ret=;
chomp $ret;
my @ret=split(/\s/, $ret, 2);
if ($ret[0] eq '1') {
# escaped data
local $_;
my $unescaped='';
for (split /(\\.)/, $ret[1]) {
s/\\(.)/$1 eq "n" ? "\n" : $1/eg;
$unescaped.=$_;
}
$ret[0]='0';
$ret[1]=$unescaped;
}
return @ret if wantarray;
return $ret[1];
};
goto &$AUTOLOAD;
}
=back
=head1 SEE ALSO
The debconf specification
(/usr/share/doc/debian-policy/debconf_specification.txt.gz).
=head1 AUTHOR
Joey Hess
=cut
1
Debconf/Gettext.pm 0000666 00000000455 15077711155 0010107 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Gettext;
use strict;
BEGIN {
eval 'use Locale::gettext';
if ($@) {
eval q{
sub gettext {
return shift;
}
};
}
else {
textdomain('debconf');
}
}
use base qw(Exporter);
our @EXPORT=qw(gettext);
1
Debconf/Base.pm 0000666 00000000763 15077711155 0007337 0 ustar 00 #!/usr/bin/perl -w
# This file was preprocessed, do not edit!
package Debconf::Base;
use Debconf::Log ':all';
use strict;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $this=bless ({@_}, $class);
$this->init;
return $this;
}
sub init {}
sub AUTOLOAD {
(my $field = our $AUTOLOAD) =~ s/.*://;
no strict 'refs';
*$AUTOLOAD = sub {
my $this=shift;
return $this->{$field} unless @_;
return $this->{$field}=shift;
};
goto &$AUTOLOAD;
}
sub DESTROY {
}
1
Text/WrapI18N.pm 0000666 00000014362 15077711155 0007362 0 ustar 00 package Text::WrapI18N;
require Exporter;
use strict;
use warnings;
our @ISA = qw(Exporter);
our @EXPORT = qw(wrap);
our @EXPORT_OK = qw($columns $separator);
our %EXPORT_TAGS = ('all' => [ @EXPORT, @EXPORT_OK ]);
our $VERSION = '0.06';
use vars qw($columns $break $tabstop $separator $huge $unexpand $charmap);
use Text::CharWidth qw(mbswidth mblen);
BEGIN {
$columns = 76;
# $break, $separator, $huge, and $unexpand are not supported yet.
$break = '\s';
$tabstop = 8;
$separator = "\n";
$huge = 'wrap';
$unexpand = 1;
undef $charmap;
}
sub wrap {
my $top1=shift;
my $top2=shift;
my $text=shift;
$text = $top1 . $text;
# $out already-formatted text for output including current line
# $len visible width of the current line without the current word
# $word the current word which might be sent to the next line
# $wlen visible width of the current word
# $c the current character
# $b whether to allow line-breaking after the current character
# $cont_lf true when LF (line feed) characters appear continuously
# $w visible width of the current character
my $out = '';
my $len = 0;
my $word = '';
my $wlen = 0;
my $cont_lf = 0;
my ($c, $w, $b);
$text =~ s/\n+$/\n/;
while(1) {
if (length($text) == 0) {
return $out . $word;
}
($c, $text, $w, $b) = _extract($text);
if ($c eq "\n") {
$out .= $word . $separator;
if (length($text) == 0) {return $out;}
$len = 0;
$text = $top2 . $text;
$word = '' ; $wlen = 0;
next;
} elsif ($w == -1) {
# all control characters other than LF are ignored
next;
}
# when the current line have enough room
# for the curren character
if ($len + $wlen + $w <= $columns) {
if ($c eq ' ' || $b) {
$out .= $word . $c;
$len += $wlen + $w;
$word = ''; $wlen = 0;
} else {
$word .= $c; $wlen += $w;
}
next;
}
# when the current line overflows with the
# current character
if ($c eq ' ') {
# the line ends by space
$out .= $word . $separator;
$len = 0;
$text = $top2 . $text;
$word = ''; $wlen = 0;
} elsif ($wlen + $w <= $columns - length ($top2)) {
# the current word is sent to next line
$out .= $separator;
$len = 0;
$text = $top2 . $word . $c . $text;
$word = ''; $wlen = 0;
} else {
# the current word is too long to fit a line
$out .= $word . $separator;
$len = 0;
$text = $top2 . $c . $text;
$word = ''; $wlen = 0;
}
}
}
# Extract one character from the beginning from the given string.
# Supports multibyte encodings such as UTF-8, EUC-JP, EUC-KR,
# GB2312, and Big5.
#
# return value: (character, rest string, width, line breakable)
# character: a character. This may consist from multiple bytes.
# rest string: given string without the extracted character.
# width: number of columns which the character occupies on screen.
# line breakable: true if the character allows line break after it.
sub _extract {
my $string=shift;
my ($l, $c, $r, $w, $b, $u);
if (length($string) == 0) {
return ('', '', 0, 0);
}
$l = mblen($string);
if ($l == 0 || $l == -1) {
return ('?', substr($string,1), 1, 0);
}
$c = substr($string, 0, $l);
$r = substr($string, $l);
$w = mbswidth($c);
if (!defined($charmap)) {
$charmap = `/usr/bin/locale charmap`;
}
if ($charmap =~ /UTF.8/i) {
# UTF-8
if ($l == 3) {
# U+0800 - U+FFFF
$u = (ord(substr($c,0,1))&0x0f) * 0x1000
+ (ord(substr($c,1,1))&0x3f) * 0x40
+ (ord(substr($c,2,1))&0x3f);
$b = _isCJ($u);
} elsif ($l == 4) {
# U+10000 - U+10FFFF
$u = (ord(substr($c,0,1))&7) * 0x40000
+ (ord(substr($c,1,1))&0x3f) * 0x1000
+ (ord(substr($c,2,1))&0x3f) * 0x40
+ (ord(substr($c,3,1))&0x3f);
$b = _isCJ($u);
} else {
$b = 0;
}
} elsif ($charmap =~ /(^EUC)|(^GB)|(^BIG)/i) {
# East Asian legacy encodings
# (EUC-JP, EUC-KR, GB2312, Big5, Big5HKSCS, and so on)
if (ord(substr($c,0,1)) >= 0x80) {$b = 1;} else {$b = 0;}
} else {
$b = 0;
}
return ($c, $r, $w, $b);
}
# Returns 1 for Chinese and Japanese characters. This means that
# these characters allow line wrapping after this character even
# without whitespaces because these languages don't use whitespaces
# between words.
#
# Character must be given in UCS-4 codepoint value.
sub _isCJ {
my $u=shift;
if ($u >= 0x3000 && $u <= 0x312f) {
if ($u == 0x300a || $u == 0x300c || $u == 0x300e ||
$u == 0x3010 || $u == 0x3014 || $u == 0x3016 ||
$u == 0x3018 || $u == 0x301a) {return 0;}
return 1;
} # CJK punctuations, Hiragana, Katakana, Bopomofo
if ($u >= 0x31a0 && $u <= 0x31bf) {return 1;} # Bopomofo
if ($u >= 0x31f0 && $u <= 0x31ff) {return 1;} # Katakana extension
if ($u >= 0x3400 && $u <= 0x9fff) {return 1;} # Han Ideogram
if ($u >= 0xf900 && $u <= 0xfaff) {return 1;} # Han Ideogram
if ($u >= 0x20000 && $u <= 0x2ffff) {return 1;} # Han Ideogram
return 0;
}
1;
__END__
=head1 NAME
Text::WrapI18N - Line wrapping module with support for multibyte, fullwidth,
and combining characters and languages without whitespaces between words
=head1 SYNOPSIS
use Text::WrapI18N qw(wrap $columns);
wrap(firstheader, nextheader, texts);
=head1 DESCRIPTION
This module intends to be a better Text::Wrap module.
This module is needed to support multibyte character encodings such
as UTF-8, EUC-JP, EUC-KR, GB2312, and Big5. This module also supports
characters with irregular widths, such as combining characters (which
occupy zero columns on terminal, like diacritical marks in UTF-8) and
fullwidth characters (which occupy two columns on terminal, like most
of east Asian characters). Also, minimal handling of languages which
doesn't use whitespaces between words (like Chinese and Japanese) is
supported.
Like Text::Wrap, hyphenation and "kinsoku" processing are not supported,
to keep simplicity.
I is the main subroutine of
Text::WrapI18N module to execute the line wrapping. Input parameters
and output data emulate Text::Wrap. The texts have to be written in
locale encoding.
=head1 SEE ALSO
locale(5), utf-8(7), charsets(7)
=head1 AUTHOR
Tomohiro KUBOTA, Ekubota@debian.orgE
=head1 COPYRIGHT AND LICENSE
Copyright 2003 by Tomohiro KUBOTA
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
Date/Language.pm 0000666 00000005110 15077711155 0007514 0 ustar 00
package Date::Language;
use strict;
use Time::Local;
use Carp;
use vars qw($VERSION @ISA);
require Date::Format;
$VERSION = "1.10";
@ISA = qw(Date::Format::Generic);
sub new
{
my $self = shift;
my $type = shift || $self;
$type =~ s/^(\w+)$/Date::Language::$1/;
croak "Bad language"
unless $type =~ /^[\w:]+$/;
eval "require $type"
or croak $@;
bless [], $type;
}
# Stop AUTOLOAD being called ;-)
sub DESTROY {}
sub AUTOLOAD
{
use vars qw($AUTOLOAD);
if($AUTOLOAD =~ /::strptime\Z/o)
{
my $self = $_[0];
my $type = ref($self) || $self;
require Date::Parse;
no strict 'refs';
*{"${type}::strptime"} = Date::Parse::gen_parser(
\%{"${type}::DoW"},
\%{"${type}::MoY"},
\@{"${type}::Dsuf"},
1);
goto &{"${type}::strptime"};
}
croak "Undefined method &$AUTOLOAD called";
}
sub str2time
{
my $me = shift;
my @t = $me->strptime(@_);
return undef
unless @t;
my($ss,$mm,$hh,$day,$month,$year,$zone) = @t;
my @lt = localtime(time);
$hh ||= 0;
$mm ||= 0;
$ss ||= 0;
$month = $lt[4]
unless(defined $month);
$day = $lt[3]
unless(defined $day);
$year = ($month > $lt[4]) ? ($lt[5] - 1) : $lt[5]
unless(defined $year);
return defined $zone ? timegm($ss,$mm,$hh,$day,$month,$year) - $zone
: timelocal($ss,$mm,$hh,$day,$month,$year);
}
1;
__END__
=head1 NAME
Date::Language - Language specific date formating and parsing
=head1 SYNOPSIS
use Date::Language;
my $lang = Date::Language->new('German');
$lang->time2str("%a %b %e %T %Y\n", time);
=head1 DESCRIPTION
L provides objects to parse and format dates for specific languages. Available languages are
Afar French Russian_cp1251
Amharic Gedeo Russian_koi8r
Austrian German Sidama
Brazilian Greek Somali
Chinese Hungarian Spanish
Chinese_GB Icelandic Swedish
Czech Italian Tigrinya
Danish Norwegian TigrinyaEritrean
Dutch Oromo TigrinyaEthiopian
English Romanian Turkish
Finnish Russian
=head1 METHODS
=over
=item time2str
See L
=item strftime
See L
=item ctime
See L
=item asctime
See L
=item str2time
See L
=item strptime
See L
=back
Date/Format.pm 0000666 00000022660 15077711155 0007232 0 ustar 00 # Copyright (c) 1995-2009 Graham Barr. This program is free
# software; you can redistribute it and/or modify it under the same terms
# as Perl itself.
package Date::Format;
use strict;
use vars qw(@EXPORT @ISA $VERSION);
require Exporter;
$VERSION = "2.24";
@ISA = qw(Exporter);
@EXPORT = qw(time2str strftime ctime asctime);
sub time2str ($;$$)
{
Date::Format::Generic->time2str(@_);
}
sub strftime ($\@;$)
{
Date::Format::Generic->strftime(@_);
}
sub ctime ($;$)
{
my($t,$tz) = @_;
Date::Format::Generic->time2str("%a %b %e %T %Y\n", $t, $tz);
}
sub asctime (\@;$)
{
my($t,$tz) = @_;
Date::Format::Generic->strftime("%a %b %e %T %Y\n", $t, $tz);
}
##
##
##
package Date::Format::Generic;
use vars qw($epoch $tzname);
use Time::Zone;
use Time::Local;
sub ctime
{
my($me,$t,$tz) = @_;
$me->time2str("%a %b %e %T %Y\n", $t, $tz);
}
sub asctime
{
my($me,$t,$tz) = @_;
$me->strftime("%a %b %e %T %Y\n", $t, $tz);
}
sub _subs
{
my $fn;
$_[1] =~ s/
%(O?[%a-zA-Z])
/
($_[0]->can("format_$1") || sub { $1 })->($_[0]);
/sgeox;
$_[1];
}
sub strftime
{
my($pkg,$fmt,$time);
($pkg,$fmt,$time,$tzname) = @_;
my $me = ref($pkg) ? $pkg : bless [];
if(defined $tzname)
{
$tzname = uc $tzname;
$tzname = sprintf("%+05d",$tzname)
unless($tzname =~ /\D/);
$epoch = timegm(@{$time}[0..5]);
@$me = gmtime($epoch + tz_offset($tzname) - tz_offset());
}
else
{
@$me = @$time;
undef $epoch;
}
_subs($me,$fmt);
}
sub time2str
{
my($pkg,$fmt,$time);
($pkg,$fmt,$time,$tzname) = @_;
my $me = ref($pkg) ? $pkg : bless [], $pkg;
$epoch = $time;
if(defined $tzname)
{
$tzname = uc $tzname;
$tzname = sprintf("%+05d",$tzname)
unless($tzname =~ /\D/);
$time += tz_offset($tzname);
@$me = gmtime($time);
}
else
{
@$me = localtime($time);
}
$me->[9] = $time;
_subs($me,$fmt);
}
my(@DoW,@MoY,@DoWs,@MoYs,@AMPM,%format,@Dsuf);
@DoW = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
@MoY = qw(January February March April May June
July August September October November December);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
%format = ('x' => "%m/%d/%y",
'C' => "%a %b %e %T %Z %Y",
'X' => "%H:%M:%S",
);
my @locale;
my $locale = "/usr/share/lib/locale/LC_TIME/default";
local *LOCALE;
if(open(LOCALE,"$locale"))
{
chop(@locale = );
close(LOCALE);
@MoYs = @locale[0 .. 11];
@MoY = @locale[12 .. 23];
@DoWs = @locale[24 .. 30];
@DoW = @locale[31 .. 37];
@format{"X","x","C"} = @locale[38 .. 40];
@AMPM = @locale[41 .. 42];
}
sub wkyr {
my($wstart, $wday, $yday) = @_;
$wday = ($wday + 7 - $wstart) % 7;
return int(($yday - $wday + 13) / 7 - 1);
}
##
## these 6 formatting routins need to be *copied* into the language
## specific packages
##
my @roman = ('',qw(I II III IV V VI VII VIII IX));
sub roman {
my $n = shift;
$n =~ s/(\d)$//;
my $r = $roman[ $1 ];
if($n =~ s/(\d)$//) {
(my $t = $roman[$1]) =~ tr/IVX/XLC/;
$r = $t . $r;
}
if($n =~ s/(\d)$//) {
(my $t = $roman[$1]) =~ tr/IVX/CDM/;
$r = $t . $r;
}
if($n =~ s/(\d)$//) {
(my $t = $roman[$1]) =~ tr/IVX/M../;
$r = $t . $r;
}
$r;
}
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_P { lc($_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0]) }
sub format_d { sprintf("%02d",$_[0]->[3]) }
sub format_e { sprintf("%2d",$_[0]->[3]) }
sub format_H { sprintf("%02d",$_[0]->[2]) }
sub format_I { sprintf("%02d",$_[0]->[2] % 12 || 12)}
sub format_j { sprintf("%03d",$_[0]->[7] + 1) }
sub format_k { sprintf("%2d",$_[0]->[2]) }
sub format_l { sprintf("%2d",$_[0]->[2] % 12 || 12)}
sub format_L { $_[0]->[4] + 1 }
sub format_m { sprintf("%02d",$_[0]->[4] + 1) }
sub format_M { sprintf("%02d",$_[0]->[1]) }
sub format_q { sprintf("%01d",int($_[0]->[4] / 3) + 1) }
sub format_s {
$epoch = timelocal(@{$_[0]}[0..5])
unless defined $epoch;
sprintf("%d",$epoch)
}
sub format_S { sprintf("%02d",$_[0]->[0]) }
sub format_U { wkyr(0, $_[0]->[6], $_[0]->[7]) }
sub format_w { $_[0]->[6] }
sub format_W { wkyr(1, $_[0]->[6], $_[0]->[7]) }
sub format_y { sprintf("%02d",$_[0]->[5] % 100) }
sub format_Y { sprintf("%04d",$_[0]->[5] + 1900) }
sub format_Z {
my $o = tz_local_offset(timelocal(@{$_[0]}[0..5]));
defined $tzname ? $tzname : uc tz_name($o, $_[0]->[8]);
}
sub format_z {
my $t = timelocal(@{$_[0]}[0..5]);
my $o = defined $tzname ? tz_offset($tzname, $t) : tz_offset(undef,$t);
sprintf("%+03d%02d", int($o / 3600), int(abs($o) % 3600) / 60);
}
sub format_c { &format_x . " " . &format_X }
sub format_D { &format_m . "/" . &format_d . "/" . &format_y }
sub format_r { &format_I . ":" . &format_M . ":" . &format_S . " " . &format_p }
sub format_R { &format_H . ":" . &format_M }
sub format_T { &format_H . ":" . &format_M . ":" . &format_S }
sub format_t { "\t" }
sub format_n { "\n" }
sub format_o { sprintf("%2d%s",$_[0]->[3],$Dsuf[$_[0]->[3]]) }
sub format_x { my $f = $format{'x'}; _subs($_[0],$f); }
sub format_X { my $f = $format{'X'}; _subs($_[0],$f); }
sub format_C { my $f = $format{'C'}; _subs($_[0],$f); }
sub format_Od { roman(format_d(@_)) }
sub format_Oe { roman(format_e(@_)) }
sub format_OH { roman(format_H(@_)) }
sub format_OI { roman(format_I(@_)) }
sub format_Oj { roman(format_j(@_)) }
sub format_Ok { roman(format_k(@_)) }
sub format_Ol { roman(format_l(@_)) }
sub format_Om { roman(format_m(@_)) }
sub format_OM { roman(format_M(@_)) }
sub format_Oq { roman(format_q(@_)) }
sub format_Oy { roman(format_y(@_)) }
sub format_OY { roman(format_Y(@_)) }
sub format_G { int(($_[0]->[9] - 315993600) / 604800) }
1;
__END__
=head1 NAME
Date::Format - Date formating subroutines
=head1 SYNOPSIS
use Date::Format;
@lt = localtime(time);
print time2str($template, time);
print strftime($template, @lt);
print time2str($template, time, $zone);
print strftime($template, @lt, $zone);
print ctime(time);
print asctime(@lt);
print ctime(time, $zone);
print asctime(@lt, $zone);
=head1 DESCRIPTION
This module provides routines to format dates into ASCII strings. They
correspond to the C library routines C and C.
=over 4
=item time2str(TEMPLATE, TIME [, ZONE])
C converts C into an ASCII string using the conversion
specification given in C. C if given specifies the zone
which the output is required to be in, C defaults to your current zone.
=item strftime(TEMPLATE, TIME [, ZONE])
C is similar to C with the exception that the time is
passed as an array, such as the array returned by C.
=item ctime(TIME [, ZONE])
C calls C with the given arguments using the
conversion specification C<"%a %b %e %T %Y\n">
=item asctime(TIME [, ZONE])
C calls C with the given arguments using the
conversion specification C<"%a %b %e %T %Y\n">
=back
=head1 MULTI-LANGUAGE SUPPORT
Date::Format is capable of formating into several languages by creating
a language specific object and calling methods, see L
my $lang = Date::Language->new('German');
$lang->time2str("%a %b %e %T %Y\n", time);
I am open to suggestions on this.
=head1 CONVERSION SPECIFICATION
Each conversion specification is replaced by appropriate
characters as described in the following list. The
appropriate characters are determined by the LC_TIME
category of the program's locale.
%% PERCENT
%a day of the week abbr
%A day of the week
%b month abbr
%B month
%c MM/DD/YY HH:MM:SS
%C ctime format: Sat Nov 19 21:05:57 1994
%d numeric day of the month, with leading zeros (eg 01..31)
%e like %d, but a leading zero is replaced by a space (eg 1..32)
%D MM/DD/YY
%G GPS week number (weeks since January 6, 1980)
%h month abbr
%H hour, 24 hour clock, leading 0's)
%I hour, 12 hour clock, leading 0's)
%j day of the year
%k hour
%l hour, 12 hour clock
%L month number, starting with 1
%m month number, starting with 01
%M minute, leading 0's
%n NEWLINE
%o ornate day of month -- "1st", "2nd", "25th", etc.
%p AM or PM
%P am or pm (Yes %p and %P are backwards :)
%q Quarter number, starting with 1
%r time format: 09:05:57 PM
%R time format: 21:05
%s seconds since the Epoch, UCT
%S seconds, leading 0's
%t TAB
%T time format: 21:05:57
%U week number, Sunday as first day of week
%w day of the week, numerically, Sunday == 0
%W week number, Monday as first day of week
%x date format: 11/19/94
%X time format: 21:05:57
%y year (2 digits)
%Y year (4 digits)
%Z timezone in ascii. eg: PST
%z timezone in format -/+0000
C<%d>, C<%e>, C<%H>, C<%I>, C<%j>, C<%k>, C<%l>, C<%m>, C<%M>, C<%q>,
C<%y> and C<%Y> can be output in Roman numerals by prefixing the letter
with C, e.g. C<%OY> will output the year as roman numerals.
=head1 LIMITATION
The functions in this module are limited to the time range that can be
represented by the time_t data type, i.e. 1901-12-13 20:45:53 GMT to
2038-01-19 03:14:07 GMT.
=head1 AUTHOR
Graham Barr
=head1 COPYRIGHT
Copyright (c) 1995-2009 Graham Barr. This program is free
software; you can redistribute it and/or modify it under the same terms
as Perl itself.
=cut
Date/Parse.pm 0000666 00000021363 15077711155 0007053 0 ustar 00 # Copyright (c) 1995-2009 Graham Barr. This program is free
# software; you can redistribute it and/or modify it under the same terms
# as Perl itself.
package Date::Parse;
require 5.000;
use strict;
use vars qw($VERSION @ISA @EXPORT);
use Time::Local;
use Carp;
use Time::Zone;
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&strtotime &str2time &strptime);
$VERSION = "2.30";
my %month = (
january => 0,
february => 1,
march => 2,
april => 3,
may => 4,
june => 5,
july => 6,
august => 7,
september => 8,
sept => 8,
october => 9,
november => 10,
december => 11,
);
my %day = (
sunday => 0,
monday => 1,
tuesday => 2,
tues => 2,
wednesday => 3,
wednes => 3,
thursday => 4,
thur => 4,
thurs => 4,
friday => 5,
saturday => 6,
);
my @suf = (qw(th st nd rd th th th th th th)) x 3;
@suf[11,12,13] = qw(th th th);
#Abbreviations
map { $month{substr($_,0,3)} = $month{$_} } keys %month;
map { $day{substr($_,0,3)} = $day{$_} } keys %day;
my $strptime = <<'ESQ';
my %month = map { lc $_ } %$mon_ref;
my $daypat = join("|", map { lc $_ } reverse sort keys %$day_ref);
my $monpat = join("|", reverse sort keys %month);
my $sufpat = join("|", reverse sort map { lc $_ } @$suf_ref);
my %ampm = (
'a' => 0, # AM
'p' => 12, # PM
);
my($AM, $PM) = (0,12);
sub {
my $dtstr = lc shift;
my $merid = 24;
my($year,$month,$day,$hh,$mm,$ss,$zone,$dst,$frac);
$zone = tz_offset(shift) if @_;
1 while $dtstr =~ s#\([^\(\)]*\)# #o;
$dtstr =~ s#(\A|\n|\Z)# #sog;
# ignore day names
$dtstr =~ s#([\d\w\s])[\.\,]\s#$1 #sog;
$dtstr =~ s/,/ /g;
$dtstr =~ s#($daypat)\s*(den\s)?\b# #o;
# Time: 12:00 or 12:00:00 with optional am/pm
return unless $dtstr =~ /\S/;
if ($dtstr =~ s/\s(\d{4})([-:]?)(\d\d?)\2(\d\d?)(?:[-Tt ](\d\d?)(?:([-:]?)(\d\d?)(?:\6(\d\d?)(?:[.,](\d+))?)?)?)?(?=\D)/ /) {
($year,$month,$day,$hh,$mm,$ss,$frac) = ($1,$3-1,$4,$5,$7,$8,$9);
}
unless (defined $hh) {
if ($dtstr =~ s#[:\s](\d\d?):(\d\d?)(:(\d\d?)(?:\.\d+)?)?(z)?\s*(?:([ap])\.?m?\.?)?\s# #o) {
($hh,$mm,$ss) = ($1,$2,$4);
$zone = 0 if $5;
$merid = $ampm{$6} if $6;
}
# Time: 12 am
elsif ($dtstr =~ s#\s(\d\d?)\s*([ap])\.?m?\.?\s# #o) {
($hh,$mm,$ss) = ($1,0,0);
$merid = $ampm{$2};
}
}
if (defined $hh and $hh <= 12 and $dtstr =~ s# ([ap])\.?m?\.?\s# #o) {
$merid = $ampm{$1};
}
unless (defined $year) {
# Date: 12-June-96 (using - . or /)
if ($dtstr =~ s#\s(\d\d?)([\-\./])($monpat)(\2(\d\d+))?\s# #o) {
($month,$day) = ($month{$3},$1);
$year = $5 if $5;
}
# Date: 12-12-96 (using '-', '.' or '/' )
elsif ($dtstr =~ s#\s(\d+)([\-\./])(\d\d?)(\2(\d+))?\s# #o) {
($month,$day) = ($1 - 1,$3);
if ($5) {
$year = $5;
# Possible match for 1995-01-24 (short mainframe date format);
($year,$month,$day) = ($1, $3 - 1, $5) if $month > 12;
return if length($year) > 2 and $year < 1901;
}
}
elsif ($dtstr =~ s#\s(\d+)\s*($sufpat)?\s*($monpat)# #o) {
($month,$day) = ($month{$3},$1);
}
elsif ($dtstr =~ s#($monpat)\s*(\d+)\s*($sufpat)?\s# #o) {
($month,$day) = ($month{$1},$2);
}
elsif ($dtstr =~ s#($monpat)([\/-])(\d+)[\/-]# #o) {
($month,$day) = ($month{$1},$3);
}
# Date: 961212
elsif ($dtstr =~ s#\s(\d\d)(\d\d)(\d\d)\s# #o) {
($year,$month,$day) = ($1,$2-1,$3);
}
$year = $1 if !defined($year) and $dtstr =~ s#\s(\d{2}(\d{2})?)[\s\.,]# #o;
}
# Zone
$dst = 1 if $dtstr =~ s#\bdst\b##o;
if ($dtstr =~ s#\s"?([a-z]{3,4})(dst|\d+[a-z]*|_[a-z]+)?"?\s# #o) {
$dst = 1 if $2 and $2 eq 'dst';
$zone = tz_offset($1);
return unless defined $zone;
}
elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?):?(\d\d)?(00)?\s# #o) {
my $m = defined($4) ? "$2$4" : 0;
my $h = "$2$3";
$zone = defined($1) ? tz_offset($1) : 0;
return unless defined $zone;
$zone += 60 * ($m + (60 * $h));
}
if ($dtstr =~ /\S/) {
# now for some dumb dates
if ($dtstr =~ s/^\s*(ut?|z)\s*$//) {
$zone = 0;
}
elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?)(\d\d)?(00)?\s# #o) {
my $m = defined($4) ? "$2$4" : 0;
my $h = "$2$3";
$zone = defined($1) ? tz_offset($1) : 0;
return unless defined $zone;
$zone += 60 * ($m + (60 * $h));
}
return if $dtstr =~ /\S/o;
}
if (defined $hh) {
if ($hh == 12) {
$hh = 0 if $merid == $AM;
}
elsif ($merid == $PM) {
$hh += 12;
}
}
$year -= 1900 if defined $year && $year > 1900;
$zone += 3600 if defined $zone && $dst;
$ss += "0.$frac" if $frac;
return ($ss,$mm,$hh,$day,$month,$year,$zone);
}
ESQ
use vars qw($day_ref $mon_ref $suf_ref $obj);
sub gen_parser
{
local($day_ref,$mon_ref,$suf_ref,$obj) = @_;
if($obj)
{
my $obj_strptime = $strptime;
substr($obj_strptime,index($strptime,"sub")+6,0) = <<'ESQ';
shift; # package
ESQ
my $sub = eval "$obj_strptime" or die $@;
return $sub;
}
eval "$strptime" or die $@;
}
*strptime = gen_parser(\%day,\%month,\@suf);
sub str2time
{
my @t = strptime(@_);
return undef
unless @t;
my($ss,$mm,$hh,$day,$month,$year,$zone) = @t;
my @lt = localtime(time);
$hh ||= 0;
$mm ||= 0;
$ss ||= 0;
my $frac = $ss - int($ss);
$ss = int $ss;
$month = $lt[4]
unless(defined $month);
$day = $lt[3]
unless(defined $day);
$year = ($month > $lt[4]) ? ($lt[5] - 1) : $lt[5]
unless(defined $year);
return undef
unless($month <= 11 && $day >= 1 && $day <= 31
&& $hh <= 23 && $mm <= 59 && $ss <= 59);
my $result;
if (defined $zone) {
$result = eval {
local $SIG{__DIE__} = sub {}; # Ick!
timegm($ss,$mm,$hh,$day,$month,$year);
};
return undef
if !defined $result
or $result == -1
&& join("",$ss,$mm,$hh,$day,$month,$year)
ne "595923311169";
$result -= $zone;
}
else {
$result = eval {
local $SIG{__DIE__} = sub {}; # Ick!
timelocal($ss,$mm,$hh,$day,$month,$year);
};
return undef
if !defined $result
or $result == -1
&& join("",$ss,$mm,$hh,$day,$month,$year)
ne join("",(localtime(-1))[0..5]);
}
return $result + $frac;
}
1;
__END__
=head1 NAME
Date::Parse - Parse date strings into time values
=head1 SYNOPSIS
use Date::Parse;
$time = str2time($date);
($ss,$mm,$hh,$day,$month,$year,$zone) = strptime($date);
=head1 DESCRIPTION
C provides two routines for parsing date strings into time values.
=over 4
=item str2time(DATE [, ZONE])
C parses C and returns a unix time value, or undef upon failure.
C, if given, specifies the timezone to assume when parsing if the
date string does not specify a timezone.
=item strptime(DATE [, ZONE])
C takes the same arguments as str2time but returns an array of
values C<($ss,$mm,$hh,$day,$month,$year,$zone)>. Elements are only defined
if they could be extracted from the date string. The C<$zone> element is
the timezone offset in seconds from GMT. An empty array is returned upon
failure.
=back
=head1 MULTI-LANGUAGE SUPPORT
Date::Parse is capable of parsing dates in several languages, these include
English, French, German and Italian.
$lang = Date::Language->new('German');
$lang->str2time("25 Jun 1996 21:09:55 +0100");
=head1 EXAMPLE DATES
Below is a sample list of dates that are known to be parsable with Date::Parse
1995:01:24T09:08:17.1823213 ISO-8601
1995-01-24T09:08:17.1823213
Wed, 16 Jun 94 07:29:35 CST Comma and day name are optional
Thu, 13 Oct 94 10:13:13 -0700
Wed, 9 Nov 1994 09:50:32 -0500 (EST) Text in ()'s will be ignored.
21 dec 17:05 Will be parsed in the current time zone
21-dec 17:05
21/dec 17:05
21/dec/93 17:05
1999 10:02:18 "GMT"
16 Nov 94 22:28:20 PST
=head1 LIMITATION
Date::Parse uses L internally, so is limited to only parsing dates
which result in valid values for Time::Local::timelocal. This generally means dates
between 1901-12-17 00:00:00 GMT and 2038-01-16 23:59:59 GMT
=head1 BUGS
When both the month and the date are specified in the date as numbers
they are always parsed assuming that the month number comes before the
date. This is the usual format used in American dates.
The reason why it is like this and not dynamic is that it must be
deterministic. Several people have suggested using the current locale,
but this will not work as the date being parsed may not be in the format
of the current locale.
My plans to address this, which will be in a future release, is to allow
the programmer to state what order they want these values parsed in.
=head1 AUTHOR
Graham Barr
=head1 COPYRIGHT
Copyright (c) 1995-2009 Graham Barr. This program is free
software; you can redistribute it and/or modify it under the same terms
as Perl itself.
=cut
Date/Language/Greek.pm 0000666 00000005412 15077711155 0010556 0 ustar 00 ##
## Greek tables
##
## Traditional date format is: DoW DD{eta} MoY Year (%A %o %B %Y)
##
## Matthew Musgrove
## Translations gratiously provided by Menelaos Stamatelos
## This module returns unicode (utf8) encoded characters. You will need to
## take the necessary steps for this to display correctly.
##
package Date::Language::Greek;
use utf8;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.00";
@DoW = (
"\x{039a}\x{03c5}\x{03c1}\x{03b9}\x{03b1}\x{03ba}\x{03ae}",
"\x{0394}\x{03b5}\x{03c5}\x{03c4}\x{03ad}\x{03c1}\x{03b1}",
"\x{03a4}\x{03c1}\x{03af}\x{03c4}\x{03b7}",
"\x{03a4}\x{03b5}\x{03c4}\x{03ac}\x{03c1}\x{03c4}\x{03b7}",
"\x{03a0}\x{03ad}\x{03bc}\x{03c0}\x{03c4}\x{03b7}",
"\x{03a0}\x{03b1}\x{03c1}\x{03b1}\x{03c3}\x{03ba}\x{03b5}\x{03c5}\x{03ae}",
"\x{03a3}\x{03ac}\x{03b2}\x{03b2}\x{03b1}\x{03c4}\x{03bf}",
);
@MoY = (
"\x{0399}\x{03b1}\x{03bd}\x{03bf}\x{03c5}\x{03b1}\x{03c1}\x{03af}\x{03bf}\x{03c5}",
"\x{03a6}\x{03b5}\x{03b2}\x{03c1}\x{03bf}\x{03c5}\x{03b1}\x{03c1}\x{03af}\x{03bf}\x{03c5}",
"\x{039c}\x{03b1}\x{03c1}\x{03c4}\x{03af}\x{03bf}\x{03c5}",
"\x{0391}\x{03c0}\x{03c1}\x{03b9}\x{03bb}\x{03af}\x{03c5}",
"\x{039c}\x{03b1}\x{0390}\x{03bf}\x{03c5}",
"\x{0399}\x{03bf}\x{03c5}\x{03bd}\x{03af}\x{03bf}\x{03c5}",
"\x{0399}\x{03bf}\x{03c5}\x{03bb}\x{03af}\x{03bf}\x{03c5}",
"\x{0391}\x{03c5}\x{03b3}\x{03bf}\x{03cd}\x{03c3}\x{03c4}\x{03bf}\x{03c5}",
"\x{03a3}\x{03b5}\x{03c0}\x{03c4}\x{03b5}\x{03bc}\x{03c4}\x{03bf}\x{03c5}",
"\x{039f}\x{03ba}\x{03c4}\x{03c9}\x{03b2}\x{03c1}\x{03af}\x{03bf}\x{03c5}",
"\x{039d}\x{03bf}\x{03b5}\x{03bc}\x{03b2}\x{03c1}\x{03af}\x{03bf}\x{03c5}",
"\x{0394}\x{03b5}\x{03ba}\x{03b5}\x{03bc}\x{03b2}\x{03c1}\x{03bf}\x{03c5}",
);
@DoWs = (
"\x{039a}\x{03c5}",
"\x{0394}\x{03b5}",
"\x{03a4}\x{03c1}",
"\x{03a4}\x{03b5}",
"\x{03a0}\x{03b5}",
"\x{03a0}\x{03b1}",
"\x{03a3}\x{03b1}",
);
@MoYs = (
"\x{0399}\x{03b1}\x{03bd}",
"\x{03a6}\x{03b5}",
"\x{039c}\x{03b1}\x{03c1}",
"\x{0391}\x{03c0}\x{03c1}",
"\x{039c}\x{03b1}",
"\x{0399}\x{03bf}\x{03c5}\x{03bd}",
"\x{0399}\x{03bf}\x{03c5}\x{03bb}",
"\x{0391}\x{03c5}\x{03b3}",
"\x{03a3}\x{03b5}\x{03c0}",
"\x{039f}\x{03ba}",
"\x{039d}\x{03bf}",
"\x{0394}\x{03b5}",
);
@AMPM = ("\x{03c0}\x{03bc}", "\x{03bc}\x{03bc}");
@Dsuf = ("\x{03b7}" x 31);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_o { sprintf("%2d%s",$_[0]->[3],"\x{03b7}") }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/TigrinyaEthiopian.pm 0000666 00000003612 15077711155 0013150 0 ustar 00 ##
## Tigrinya-Ethiopian tables
##
package Date::Language::TigrinyaEthiopian;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.00";
if ( $] >= 5.006 ) {
@DoW = (
"\x{1230}\x{1295}\x{1260}\x{1275}",
"\x{1230}\x{1291}\x{12ed}",
"\x{1230}\x{1209}\x{1235}",
"\x{1228}\x{1261}\x{12d5}",
"\x{1213}\x{1219}\x{1235}",
"\x{12d3}\x{122d}\x{1262}",
"\x{1240}\x{12f3}\x{121d}"
);
@MoY = (
"\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}",
"\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}",
"\x{121b}\x{122d}\x{127d}",
"\x{12a4}\x{1355}\x{1228}\x{120d}",
"\x{121c}\x{12ed}",
"\x{1301}\x{1295}",
"\x{1301}\x{120b}\x{12ed}",
"\x{12a6}\x{1308}\x{1235}\x{1275}",
"\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}",
"\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}",
"\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}",
"\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = (
"\x{1295}/\x{1230}",
"\x{12F5}/\x{1230}"
);
@Dsuf = ("\x{12ed}" x 31);
}
else {
@DoW = (
"ሰንበት",
"ሰኑይ",
"ሰሉስ",
"ረቡዕ",
"ሓሙስ",
"ዓርቢ",
"ቀዳም"
);
@MoY = (
"ጃንዩወሪ",
"ፌብሩወሪ",
"ማርች",
"ኤፕረል",
"ሜይ",
"ጁን",
"ጁላይ",
"ኦገስት",
"ሴፕቴምበር",
"ኦክተውበር",
"ኖቬምበር",
"ዲሴምበር"
);
@DoWs = map { substr($_,0,9) } @DoW;
@MoYs = map { substr($_,0,9) } @MoY;
@AMPM = (
"ን/ሰ",
"ድ/ሰ"
);
@Dsuf = ("ይ" x 31);
}
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Turkish.pm 0000666 00000004037 15077711155 0011154 0 ustar 00 #----------------------------------------------------#
#
# Turkish tables
# Burak Grsoy
# Last modified: Sat Nov 15 20:28:32 2003
#
# use Date::Language;
# my $turkish = Date::Language->new('Turkish');
# print $turkish->time2str("%e %b %Y, %a %T\n", time);
# print $turkish->str2time("25 Haz 1996 21:09:55 +0100");
#----------------------------------------------------#
package Date::Language::Turkish;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION %DsufMAP);
@ISA = qw(Date::Language);
$VERSION = "1.0";
@DoW = qw(Pazar Pazartesi Sal aramba Perembe Cuma Cumartesi);
@MoY = qw(Ocak ubat Mart Nisan Mays Haziran Temmuz Austos Eyll Ekim Kasm Aralk);
@DoWs = map { substr($_,0,3) } @DoW;
$DoWs[1] = 'Pzt'; # Since we'll get two 'Paz' s
$DoWs[-1] = 'Cmt'; # Since we'll get two 'Cum' s
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = ('',''); # no am-pm thingy
# not easy as in english... maybe we can just use a dot "." ? :)
%DsufMAP = (
(map {$_ => 'inci', $_+10 => 'inci', $_+20 => 'inci' } 1,2,5,8 ),
(map {$_ => 'nci', $_+10 => 'nci', $_+20 => 'nci' } 7 ),
(map {$_ => 'nci', $_+10 => 'nci', $_+20 => 'nci' } 2 ),
(map {$_ => 'nc', $_+10 => 'nc', $_+20 => 'nc' } 3,4 ),
(map {$_ => 'uncu', $_+10 => 'uncu', $_+20 => 'uncu' } 9 ),
(map {$_ => 'nc', $_+10 => 'nc', $_+20 => 'nc' } 6 ),
(map {$_ => 'uncu', } 10,30 ),
20 => 'nci',
31 => 'inci',
);
@Dsuf = map{ $DsufMAP{$_} } sort {$a <=> $b} keys %DsufMAP;
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[ $_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[ $_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { '' } # disable
sub format_P { '' } # disable
sub format_o { sprintf("%2d%s",$_[0]->[3],$Dsuf[$_[0]->[3]-1]) }
1;
__END__
Date/Language/Chinese_GB.pm 0000666 00000001626 15077711155 0011452 0 ustar 00 ##
## English tables
##
package Date::Language::Chinese_GB;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@DoW = qw( һ ڶ );
@MoY = qw(һ
ʮ ʮһ ʮ);
@DoWs = map { $_ } @DoW;
@MoYs = map { $_ } @MoY;
@AMPM = qw( );
@Dsuf = (qw( )) x 3;
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2d%s",$_[0]->[3],"") }
1;
Date/Language/Tigrinya.pm 0000666 00000002632 15077711155 0011310 0 ustar 00 ##
## Tigrinya tables
##
package Date::Language::Tigrinya;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.00";
@DoW = (
"\x{1230}\x{1295}\x{1260}\x{1275}",
"\x{1230}\x{1291}\x{12ed}",
"\x{1230}\x{1209}\x{1235}",
"\x{1228}\x{1261}\x{12d5}",
"\x{1213}\x{1219}\x{1235}",
"\x{12d3}\x{122d}\x{1262}",
"\x{1240}\x{12f3}\x{121d}"
);
@MoY = (
"\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}",
"\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}",
"\x{121b}\x{122d}\x{127d}",
"\x{12a4}\x{1355}\x{1228}\x{120d}",
"\x{121c}\x{12ed}",
"\x{1301}\x{1295}",
"\x{1301}\x{120b}\x{12ed}",
"\x{12a6}\x{1308}\x{1235}\x{1275}",
"\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}",
"\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}",
"\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}",
"\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = (
"\x{1295}/\x{1230}",
"\x{12F5}/\x{1230}"
);
@Dsuf = ("\x{12ed}" x 31);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Chinese.pm 0000666 00000001721 15077711155 0011076 0 ustar 00 ##
## English tables
##
package Date::Language::Chinese;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.00";
@DoW = qw(星期日 星期一 星期二 星期三 星期四 星期五 星期六);
@MoY = qw(一月 二月 三月 四月 五月 六月
七月 八月 九月 十月 十一月 十二月);
@DoWs = map { $_ } @DoW;
@MoYs = map { $_ } @MoY;
@AMPM = qw(上午 下午);
@Dsuf = (qw(日 日 日 日 日 日 日 日 日 日)) x 3;
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2d%s",$_[0]->[3],"日") }
1;
Date/Language/Italian.pm 0000666 00000001756 15077711155 0011111 0 ustar 00 ##
## Italian tables
##
package Date::Language::Italian;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@MoY = qw(Gennaio Febbraio Marzo Aprile Maggio Giugno
Luglio Agosto Settembre Ottobre Novembre Dicembre);
@MoYs = qw(Gen Feb Mar Apr Mag Giu Lug Ago Set Ott Nov Dic);
@DoW = qw(Domenica Lunedi Martedi Mercoledi Giovedi Venerdi Sabato);
@DoWs = qw(Dom Lun Mar Mer Gio Ven Sab);
use Date::Language::English ();
@AMPM = @{Date::Language::English::AMPM};
@Dsuf = @{Date::Language::English::Dsuf};
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Spanish.pm 0000666 00000001632 15077711155 0011126 0 ustar 00 ##
## Spanish tables
##
package Date::Language::Spanish;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.00";
@DoW = qw(domingo lunes martes mircoles jueves viernes sbado);
@MoY = qw(enero febrero marzo abril mayo junio
julio agosto septiembre octubre noviembre diciembre);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = ((qw(ro do ro to to to mo vo no mo)) x 3, 'ro');
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Austrian.pm 0000666 00000001742 15077711155 0011311 0 ustar 00 ##
## Austrian tables
##
package Date::Language::Austrian;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@MoY = qw(Jnner Feber Mrz April Mai Juni
Juli August September Oktober November Dezember);
@MoYs = qw(Jn Feb Mr Apr Mai Jun Jul Aug Sep Oct Nov Dez);
@DoW = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
@DoWs = qw(Son Mon Die Mit Don Fre Sam);
use Date::Language::English ();
@AMPM = @{Date::Language::English::AMPM};
@Dsuf = @{Date::Language::English::Dsuf};
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Sidama.pm 0000666 00000001724 15077711155 0010721 0 ustar 00 ##
## Sidama tables
##
package Date::Language::Sidama;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "0.99";
@DoW = qw(Sambata Sanyo Maakisanyo Roowe Hamuse Arbe Qidaame);
@MoY = qw(January February March April May June
July August September October November December);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(soodo hawwaro);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Russian_koi8r.pm 0000666 00000002012 15077711155 0012252 0 ustar 00 ##
## Russian koi8r
##
package Date::Language::Russian_koi8r;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@DoW = qw( );
@MoY = qw(
);
@DoWs = qw( );
#@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = ('e') x 31;
#@Dsuf[11,12,13] = qw( );
#@Dsuf[30,31] = qw( );
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
Date/Language/Czech.pm 0000666 00000002603 15077711155 0010554 0 ustar 00 ##
## Czech tables
##
## Contributed by Honza Pazdziora
package Date::Language::Czech;
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @MoY2 @AMPM %MoY %DoW $VERSION);
@ISA = qw(Date::Language Date::Format::Generic);
$VERSION = "1.01";
@MoY = qw(leden nor bezen duben kvten erven ervenec srpen z
jen listopad prosinec);
@MoYs = qw(led nor be dub kv vn ec srp z j lis pro);
@MoY2 = @MoY;
for (@MoY2)
{ s!en$!na! or s!ec$!ce! or s!ad$!adu! or s!or$!ora!; }
@DoW = qw(nedle pondl ter steda tvrtek ptek sobota);
@DoWs = qw(Ne Po t St t P So);
@AMPM = qw(dop. odp.);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_d { $_[0]->[3] }
sub format_m { $_[0]->[4] + 1 }
sub format_o { $_[0]->[3] . '.' }
sub format_Q { $MoY2[$_[0]->[4]] }
sub time2str {
my $ref = shift;
my @a = @_;
$a[0] =~ s/(%[do]\.?\s?)%B/$1%Q/;
$ref->SUPER::time2str(@a);
}
sub strftime {
my $ref = shift;
my @a = @_;
$a[0] =~ s/(%[do]\.?\s?)%B/$1%Q/;
$ref->SUPER::time2str(@a);
}
1;
Date/Language/Swedish.pm 0000666 00000002142 15077711155 0011124 0 ustar 00 ##
## Swedish tables
## Contributed by Matthew Musgrove
## Corrected by dempa
##
package Date::Language::Swedish;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@MoY = qw(januari februari mars april maj juni juli augusti september oktober november december);
@MoYs = map { substr($_,0,3) } @MoY;
@DoW = map($_ . "dagen", qw(sn mn tis ons tors fre lr));
@DoWs = map { substr($_,0,2) } @DoW;
# the ordinals are not typically used in modern times
@Dsuf = ('a' x 2, 'e' x 29);
use Date::Language::English ();
@AMPM = @{Date::Language::English::AMPM};
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
Date/Language/Dutch.pm 0000666 00000002076 15077711155 0010573 0 ustar 00 ##
## Dutch tables
## Contributed by Johannes la Poutre
##
package Date::Language::Dutch;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.02";
@MoY = qw(januari februari maart april mei juni juli
augustus september oktober november december);
@MoYs = map(substr($_, 0, 3), @MoY);
$MoYs[2] = 'mrt'; # mrt is more common (Frank Maas)
@DoW = map($_ . "dag", qw(zon maan dins woens donder vrij zater));
@DoWs = map(substr($_, 0, 2), @DoW);
# these aren't normally used...
@AMPM = qw(VM NM);
@Dsuf = ('e') x 31;
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
Date/Language/Icelandic.pm 0000666 00000002015 15077711155 0011370 0 ustar 00 ##
## Icelandic tables
##
package Date::Language::Icelandic;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@MoY = qw(Janar Febrar Mars Aprl Ma Jni
Jli gst September Oktber Nvember Desember);
@MoYs = qw(Jan Feb Mar Apr Ma Jn Jl g Sep Okt Nv Des);
@DoW = qw(Sunnudagur Mnudagur rijudagur Mivikudagur Fimmtudagur Fstudagur Laugardagur Sunnudagur);
@DoWs = qw(Sun Mn ri Mi Fim Fs Lau Sun);
use Date::Language::English ();
@AMPM = @{Date::Language::English::AMPM};
@Dsuf = @{Date::Language::English::Dsuf};
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Finnish.pm 0000666 00000002327 15077711155 0011121 0 ustar 00 ##
## Finnish tables
## Contributed by Matthew Musgrove
## Corrected by roke
##
package Date::Language::Finnish;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
# In Finnish, the names of the months and days are only capitalized at the beginning of sentences.
@MoY = map($_ . "kuu", qw(tammi helmi maalis huhti touko kes hein elo syys loka marras joulu));
@DoW = qw(sunnuntai maanantai tiistai keskiviikko torstai perjantai lauantai);
# it is not customary to use abbreviated names of months or days
# per Graham's suggestion:
@MoYs = @MoY;
@DoWs = @DoW;
# the short form of ordinals
@Dsuf = ('.') x 31;
# doesn't look like this is normally used...
@AMPM = qw(ap ip);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1; Date/Language/Romanian.pm 0000666 00000001574 15077711155 0011272 0 ustar 00 ##
## Italian tables
##
package Date::Language::Romanian;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@MoY = qw(ianuarie februarie martie aprilie mai iunie
iulie august septembrie octombrie noembrie decembrie);
@DoW = qw(duminica luni marti miercuri joi vineri sambata);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = ('') x 31;
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Amharic.pm 0000666 00000003607 15077711155 0011071 0 ustar 00 ##
## Amharic tables
##
package Date::Language::Amharic;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.00";
if ( $] >= 5.006 ) {
@DoW = (
"\x{12a5}\x{1211}\x{12f5}",
"\x{1230}\x{129e}",
"\x{121b}\x{12ad}\x{1230}\x{129e}",
"\x{1228}\x{1261}\x{12d5}",
"\x{1210}\x{1219}\x{1235}",
"\x{12d3}\x{122d}\x{1265}",
"\x{1245}\x{12f3}\x{121c}"
);
@MoY = (
"\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}",
"\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}",
"\x{121b}\x{122d}\x{127d}",
"\x{12a4}\x{1355}\x{1228}\x{120d}",
"\x{121c}\x{12ed}",
"\x{1301}\x{1295}",
"\x{1301}\x{120b}\x{12ed}",
"\x{12a6}\x{1308}\x{1235}\x{1275}",
"\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}",
"\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}",
"\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}",
"\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = ( "\x{1320}\x{12cb}\x{1275}", "\x{12a8}\x{1230}\x{12d3}\x{1275}" );
@Dsuf = ("\x{129b}" x 31);
}
else {
@DoW = (
"እሑድ",
"ሰኞ",
"ማክሰኞ",
"ረቡዕ",
"ሐሙስ",
"ዓርብ",
"ቅዳሜ"
);
@MoY = (
"ጃንዩወሪ",
"ፌብሩወሪ",
"ማርች",
"ኤፕረል",
"ሜይ",
"ጁን",
"ጁላይ",
"ኦገስት",
"ሴፕቴምበር",
"ኦክተውበር",
"ኖቬምበር",
"ዲሴምበር"
);
@DoWs = map { substr($_,0,9) } @DoW;
@MoYs = map { substr($_,0,9) } @MoY;
@AMPM = ( "ጠዋት", "ከሰዓት" );
@Dsuf = ("ኛ" x 31);
}
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Afar.pm 0000666 00000002010 15077711155 0010361 0 ustar 00 ##
## Afar tables
##
package Date::Language::Afar;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "0.99";
@DoW = qw(Acaada Etleeni Talaata Arbaqa Kamiisi Gumqata Sabti);
@MoY = (
"Qunxa Garablu",
"Kudo",
"Ciggilta Kudo",
"Agda Baxis",
"Caxah Alsa",
"Qasa Dirri",
"Qado Dirri",
"Liiqen",
"Waysu",
"Diteli",
"Ximoli",
"Kaxxa Garablu"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(saaku carra);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/English.pm 0000666 00000001715 15077711155 0011114 0 ustar 00 ##
## English tables
##
package Date::Language::English;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@DoW = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
@MoY = qw(January February March April May June
July August September October November December);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Oromo.pm 0000666 00000001747 15077711155 0010623 0 ustar 00 ##
## Oromo tables
##
package Date::Language::Oromo;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "0.99";
@DoW = qw(Dilbata Wiixata Qibxata Roobii Kamiisa Jimaata Sanbata);
@MoY = qw(Amajjii Guraandhala Bitooteessa Elba Caamsa Waxabajjii
Adooleessa Hagayya Fuulbana Onkololeessa Sadaasa Muddee);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(WD WB);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Somali.pm 0000666 00000002203 15077711155 0010740 0 ustar 00 ##
## Somali tables
##
package Date::Language::Somali;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "0.99";
@DoW = qw(Axad Isniin Salaaso Arbaco Khamiis Jimco Sabti);
@MoY = (
"Bisha Koobaad",
"Bisha Labaad",
"Bisha Saddexaad",
"Bisha Afraad",
"Bisha Shanaad",
"Bisha Lixaad",
"Bisha Todobaad",
"Bisha Sideedaad",
"Bisha Sagaalaad",
"Bisha Tobnaad",
"Bisha Kow iyo Tobnaad",
"Bisha Laba iyo Tobnaad"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = (
"Kob",
"Lab",
"Sad",
"Afr",
"Sha",
"Lix",
"Tod",
"Sid",
"Sag",
"Tob",
"KIT",
"LIT"
);
@AMPM = qw(SN GN);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/German.pm 0000666 00000002020 15077711155 0010722 0 ustar 00 ##
## German tables
##
package Date::Language::German;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.02";
@MoY = qw(Januar Februar Mrz April Mai Juni
Juli August September Oktober November Dezember);
@MoYs = qw(Jan Feb Mr Apr Mai Jun Jul Aug Sep Okt Nov Dez);
@DoW = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
@DoWs = qw(Son Mon Die Mit Don Fre Sam);
use Date::Language::English ();
@AMPM = @{Date::Language::English::AMPM};
@Dsuf = @{Date::Language::English::Dsuf};
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2d.",$_[0]->[3]) }
1;
Date/Language/French.pm 0000666 00000001740 15077711155 0010726 0 ustar 00 ##
## French tables, contributed by Emmanuel Bataille (bem@residents.frmug.org)
##
package Date::Language::French;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.04";
@DoW = qw(dimanche lundi mardi mercredi jeudi vendredi samedi);
@MoY = qw(janvier fvrier mars avril mai juin
juillet aot septembre octobre novembre dcembre);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
$MoYs[6] = 'jul';
@AMPM = qw(AM PM);
@Dsuf = ((qw(er e e e e e e e e e)) x 3, 'er');
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Gedeo.pm 0000666 00000002050 15077711155 0010537 0 ustar 00 ##
## Gedeo tables
##
package Date::Language::Gedeo;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "0.99";
@DoW = qw( Sanbbattaa Sanno Masano Roobe Hamusse Arbe Qiddamme);
@MoY = (
"Oritto",
"Birre'a",
"Onkkollessa",
"Saddasa",
"Arrasa",
"Qammo",
"Ella",
"Waacibajje",
"Canissa",
"Addolessa",
"Bittitotessa",
"Hegeya"
);
@DoWs = map { substr($_,0,3) } @DoW;
$DoWs[0] = "Snb";
$DoWs[1] = "Sno";
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(gorsa warreti-udumma);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Hungarian.pm 0000666 00000004125 15077711155 0011435 0 ustar 00 ##
## Hungarian tables based on English
##
#
# This is a just-because-I-stumbled-across-it
# -and-my-wife-is-Hungarian release: if Graham or
# someone adds to docs to Date::Format, I'd be
# glad to correct bugs and extend as neeed.
#
package Date::Language::Hungarian;
=head1 NAME
Date::Language::Hungarian - Magyar format for Date::Format
=head1 SYNOPSIS
my $lang = Date::Language->new('Hungarian');
print $lang->time2str("%a %b %e %T %Y", time);
@lt = localtime(time);
print $lang->time2str($template, time);
print $lang->strftime($template, @lt);
print $lang->time2str($template, time, $zone);
print $lang->strftime($template, @lt, $zone);
print $lang->ctime(time);
print $lang->asctime(@lt);
print $lang->ctime(time, $zone);
print $lang->asctime(@lt, $zone);
See L.
=head1 AUTHOR
Paula Goddard (paula -at- paulacska -dot- com)
=head1 LICENCE
Made available under the same terms as Perl itself.
=cut
use strict;
use warnings;
use base "Date::Language";
use vars qw( @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
$VERSION = "1.01";
@DoW = qw(Vasrnap Htf Kedd Szerda Cstrtk Pntek Szombat);
@MoY = qw(Janur Februr Mrcius prilis Mjus Jnius
Jlius Augusztus Szeptember Oktber November December);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(DE. DU.);
# There is no 'th or 'nd in Hungarian, just a dot
@Dsuf = (".") x 31;
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_P { lc($_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0]) }
sub format_o { $_[0]->[3].'.' }
sub format_D { &format_y . "." . &format_m . "." . &format_d }
sub format_y { sprintf("%02d",$_[0]->[5] % 100) }
sub format_d { sprintf("%02d",$_[0]->[3]) }
sub format_m { sprintf("%02d",$_[0]->[4] + 1) }
1;
Date/Language/Russian_cp1251.pm 0000666 00000002014 15077711155 0012133 0 ustar 00 ##
## Russian cp1251
##
package Date::Language::Russian_cp1251;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@DoW = qw( );
@MoY = qw(
);
@DoWs = qw( );
#@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = ('e') x 31;
#@Dsuf[11,12,13] = qw( );
#@Dsuf[30,31] = qw( );
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
Date/Language/Norwegian.pm 0000666 00000001754 15077711155 0011457 0 ustar 00 ##
## Norwegian tables
##
package Date::Language::Norwegian;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@MoY = qw(Januar Februar Mars April Mai Juni
Juli August September Oktober November Desember);
@MoYs = qw(Jan Feb Mar Apr Mai Jun Jul Aug Sep Okt Nov Des);
@DoW = qw(Sndag Mandag Tirsdag Onsdag Torsdag Fredag Lrdag Sndag);
@DoWs = qw(Sn Man Tir Ons Tor Fre Lr Sn);
use Date::Language::English ();
@AMPM = @{Date::Language::English::AMPM};
@Dsuf = @{Date::Language::English::Dsuf};
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Brazilian.pm 0000666 00000001706 15077711155 0011436 0 ustar 00 ##
## Brazilian tables, contributed by Christian Tosta (tosta@cce.ufmg.br)
##
package Date::Language::Brazilian;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@DoW = qw(Domingo Segunda Tera Quarta Quinta Sexta Sbado);
@MoY = qw(Janeiro Fevereiro Maro Abril Maio Junho
Julho Agosto Setembro Outubro Novembro Dezembro);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = (qw(mo ro do ro to to to mo vo no)) x 3;
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/TigrinyaEritrean.pm 0000666 00000003560 15077711155 0013003 0 ustar 00 ##
## Tigrinya-Eritrean tables
##
package Date::Language::TigrinyaEritrean;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.00";
if ( $] >= 5.006 ) {
@DoW = (
"\x{1230}\x{1295}\x{1260}\x{1275}",
"\x{1230}\x{1291}\x{12ed}",
"\x{1230}\x{1209}\x{1235}",
"\x{1228}\x{1261}\x{12d5}",
"\x{1213}\x{1219}\x{1235}",
"\x{12d3}\x{122d}\x{1262}",
"\x{1240}\x{12f3}\x{121d}"
);
@MoY = (
"\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}",
"\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}",
"\x{121b}\x{122d}\x{127d}",
"\x{12a4}\x{1355}\x{1228}\x{120d}",
"\x{121c}\x{12ed}",
"\x{1301}\x{1295}",
"\x{1301}\x{120b}\x{12ed}",
"\x{12a6}\x{1308}\x{1235}\x{1275}",
"\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}",
"\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}",
"\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}",
"\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = (
"\x{1295}/\x{1230}",
"\x{12F5}/\x{1230}"
);
@Dsuf = ("\x{12ed}" x 31);
}
else {
@DoW = (
"ሰንበት",
"ሰኑይ",
"ሰሉስ",
"ረቡዕ",
"ሓሙስ",
"ዓርቢ",
"ቀዳም"
);
@MoY = (
"ጥሪ",
"ለካቲት",
"መጋቢት",
"ሚያዝያ",
"ግንቦት",
"ሰነ",
"ሓምለ",
"ነሓሰ",
"መስከረም",
"ጥቅምቲ",
"ሕዳር",
"ታሕሳስ"
);
@DoWs = map { substr($_,0,9) } @DoW;
@MoYs = map { substr($_,0,9) } @MoY;
@AMPM = (
"ን/ሰ",
"ድ/ሰ"
);
@Dsuf = ("ይ" x 31);
}
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Date/Language/Russian.pm 0000666 00000002550 15077711155 0011145 0 ustar 00 ##
## Russian tables
##
## Contributed by Danil Pismenny
package Date::Language::Russian;
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @MoY2 @AMPM %MoY %DoW $VERSION);
@ISA = qw(Date::Language Date::Format::Generic);
$VERSION = "1.01";
@MoY = qw( );
@MoY2 = qw( );
@MoYs = qw( );
@DoW = qw( );
@DoWs = qw( );
@DoWs2 = qw( );
@AMPM = qw( );
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_d { $_[0]->[3] }
sub format_m { $_[0]->[4] + 1 }
sub format_o { $_[0]->[3] . '.' }
sub format_Q { $MoY2[$_[0]->[4]] }
sub str2time {
my ($self,$value) = @_;
map {$value=~s/(\s|^)$DoWs2[$_](\s)/$DoWs[$_]$2/ig} (0..6);
$value=~s/(\s+|^)(\s+)/$1$2/;
return $self->SUPER::str2time($value);
}
1;
Date/Language/Danish.pm 0000666 00000002013 15077711155 0010721 0 ustar 00 ##
## Danish tables
##
package Date::Language::Danish;
use Date::Language ();
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
@ISA = qw(Date::Language);
$VERSION = "1.01";
@MoY = qw(Januar Februar Marts April Maj Juni
Juli August September Oktober November December);
@MoYs = qw(Jan Feb Mar Apr Maj Jun Jul Aug Sep Okt Nov Dec);
@DoW = qw(Sndag Mandag Tirsdag Onsdag Torsdag Fredag Lrdag Sndag);
@DoWs = qw(Sn Man Tir Ons Tor Fre Lr Sn);
use Date::Language::English ();
@AMPM = @{Date::Language::English::AMPM};
@Dsuf = @{Date::Language::English::Dsuf};
@MoY{@MoY} = (0 .. scalar(@MoY));
@MoY{@MoYs} = (0 .. scalar(@MoYs));
@DoW{@DoW} = (0 .. scalar(@DoW));
@DoW{@DoWs} = (0 .. scalar(@DoWs));
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
Bundle/PlRPC.pm 0000666 00000000542 15077711155 0007251 0 ustar 00 package Bundle::PlRPC;
$VERSION = '0.03';
1;
__END__
=head1 NAME
Bundle::PlRPC - A bundle to install PlRPC-Server, Client and prerequisites.
=head1 SYNOPSIS
C
=head1 CONTENTS
Storable
Net::Daemon
RPC::PlServer
=head1 DESCRIPTION
This bundle includes all that's needed to run PlRPC-Server and Client.
Debian/AdduserCommon.pm 0000666 00000014047 15077711155 0011047 0 ustar 00 use vars qw(@EXPORT $VAR1);
# Common functions that are used in adduser and deluser
# Copyright (C) 2000 Roland Bauerschmidt
# Most of the functions are adopted from the original adduser
# Copyright (C) 1997, 1998, 1999 Guy Maor
# Copyright (C) 1995 Ted Hajek
# Ian A. Murdock
#
@EXPORT = qw(invalidate_nscd gtx dief warnf read_config get_users_groups get_group_members s_print s_printf systemcall);
sub invalidate_nscd {
# Check if we need to do make -C /var/yp for NIS
my $nisconfig;
if(-f "/etc/default/nis") {
$nisconfig = "/etc/default/nis";
} elsif(-f "/etc/init.d/nis") {
$nisconfig = "/etc/init.d/nis";
}
# find out whether a local ypserv is running
# We can ditch any rpcinfo error since if the portmapper is nonfunctional,
# we couldn't connect to ypserv anyway. If this assumption is invalid,
# please file a bug and suggest a better way.
if(defined($nisconfig) && -f "/var/yp/Makefile" &&
-x "/usr/bin/rpcinfo" && grep(/ypserv/, qx{/usr/bin/rpcinfo -p 2>/dev/null})) {
open(NISCONFIG, "<$nisconfig");
if(grep(/^NISSERVER=master/, )) {
system("make", "-C", "/var/yp");
}
close(NISCONFIG);
}
# Check if we need to invalidate the NSCD cache
my $nscd = &which('nscd',1);
# this function replaces startnscd and stopnscd (closes: #54726)
# We are ignoring any error messages given by nscd here since we
# cannot expect the nscd maintainer and upstream to document their
# interfaces. See #330929.
if(defined($nscd) && -x $nscd)
{
my $table = shift;
if ($table)
{
system ($nscd, "-i", $table);
}
else
{
# otherwise we invalidate passwd and group table
system ($nscd, "-i", "passwd");
system ($nscd, "-i", "group");
}
}
}
sub gtx {
return gettext( shift );
}
sub dief {
my ($form,@argu)=@_;
printf STDERR sprintf(gtx("%s: %s"), $0, $form), @argu;
exit 1;
}
sub warnf {
my ($form,@argu)=@_;
printf STDERR sprintf(gtx("%s: %s"), $0, $form), @argu;
}
# parse the configuration file
# parameters:
# -- filename of the configuration file
# -- a hash for the configuration data
sub read_config {
my ($conf_file, $configref) = @_;
my ($var, $lcvar, $val);
if (! -f $conf_file) {
warnf gtx("`%s' does not exist. Using defaults.\n"),$conf_file if $verbose;
return;
}
open (CONF, $conf_file) || dief ("%s: `%s'\n",$conf_file,$!);
while () {
chomp;
next if /^#/ || /^\s*$/;
if ((($var, $val) = /^\s*([_a-zA-Z0-9]+)\s*=\s*(.*)/) != 2) {
warnf gtx("Couldn't parse `%s', line %d.\n"),$conf_file,$.;
next;
}
$lcvar = lc $var;
if (!defined($configref->{$lcvar})) {
warnf gtx("Unknown variable `%s' at `%s', line %d.\n"),$var,$conf_file,$.;
next;
}
$val =~ s/^"(.*)"$/$1/;
$val =~ s/^'(.*)'$/$1/;
$configref->{$lcvar} = $val;
}
close CONF || die "$!";
}
# return a user's groups
sub get_users_groups {
my($user) = @_;
my($name,$members,@groups);
setgrent;
while (($name,$members) = (getgrent)[0,3]) {
for (split(/ /, $members)) {
if ($user eq $_) {
push @groups, $name;
last;
}
}
}
endgrent;
@groups;
}
# return a group's members
sub get_group_members
{
my $group = shift;
my @members;
foreach (split(/ /, (getgrnam($group))[3])) {
if (getpwuid(getpwnam($_)) eq $_ ) {
push @members, $_;
}
}
return @members;
}
sub s_print
{
print join(" ",@_)
if($verbose);
}
sub s_printf
{
printf @_
if($verbose);
}
sub d_printf
{
printf @_
if((defined($verbose) && $verbose > 1) || (defined($debugging) && $debugging == 1));
}
sub systemcall {
my $c = join(' ', @_);
print ("$c\n") if $verbose==2;
if (system(@_)) {
dief (gtx("`%s' returned error code %d. Exiting.\n"), $c, $?>>8)
if ($?>>8);
dief (gtx("`%s' exited from signal %d. Exiting.\n"), $c, $?&255);
}
}
sub which {
my ($progname, $nonfatal) = @_ ;
for my $dir (split /:/, $ENV{"PATH"}) {
if (-x "$dir/$progname" ) {
return "$dir/$progname";
}
}
dief(gtx("Could not find program named `%s' in \$PATH.\n"), $progname) unless ($nonfatal);
return 0;
}
# preseed the configuration variables
# then read the config file /etc/adduser and overwrite the data hardcoded here
sub preseed_config {
my ($conflistref, $configref) = @_;
$configref->{"system"} = 0;
$configref->{"only_if_empty"} = 0;
$configref->{"remove_home"} = 0;
$configref->{"home"} = "";
$configref->{"remove_all_files"} = 0;
$configref->{"backup"} = 0;
$configref->{"backup_to"} = ".";
$configref->{"dshell"} = "/bin/bash";
$configref->{"first_system_uid"} = 100;
$configref->{"last_system_uid"} = 999;
$configref->{"first_uid"} = 1000;
$configref->{"last_uid"} = 29999;
$configref->{"first_system_gid"} = 100;
$configref->{"last_system_gid"} = 999;
$configref->{"first_gid"} = 1000;
$configref->{"last_gid"} = 29999;
$configref->{"dhome"} = "/home";
$configref->{"skel"} = "/etc/skel";
$configref->{"usergroups"} = "yes";
$configref->{"users_gid"} = "100";
$configref->{"grouphomes"} = "no";
$configref->{"letterhomes"} = "no";
$configref->{"quotauser"} = "";
$configref->{"dir_mode"} = "0755";
$configref->{"setgid_home"} = "no";
$configref->{"no_del_paths"} = "^/$ ^/lost+found/.* ^/media/.* ^/mnt/.* ^/etc/.* ^/bin/.* ^/boot/.* ^/dev/.* ^/lib/.* ^/proc/.* ^/root/.* ^/sbin/.* ^/tmp/.* ^/sys/.* ^/srv/.* ^/opt/.* ^/initrd/.* ^/usr/.* ^/var/.*";
$configref->{"name_regex"} = "^[a-z][-a-z0-9_]*\$";
$configref->{"exclude_fstypes"} = "(proc|sysfs|usbfs|devpts|tmpfs)";
$configref->{"skel_ignore_regex"} = "dpkg-(old|new|dist)\$";
$configref->{"extra_groups"} = "dialout cdrom floppy audio video plugdev users";
$configref->{"add_extra_groups"} = 0;
foreach( @$conflistref ) {
read_config($_,$configref);
}
}
# Local Variables:
# mode:cperl
# End:
#vim:set ai et sts=4 sw=4 tw=0:
Debian/Debhelper/Sequence/perl_dbi.pm 0000666 00000000512 15077711155 0013521 0 ustar 00 # perl_dbi.pm - debhelper addon for running dh_perl_dbi
#
# Copyright 2010, Ansgar Burchardt
#
# This program is free software, you can redistribute it and/or modify it
# under the same terms as Perl itself.
use warnings;
use strict;
use Debian::Debhelper::Dh_Lib;
insert_after("dh_perl", "dh_perl_dbi");
1;
Debian/Debhelper/Sequence/python2.pm 0000666 00000000337 15077711155 0013351 0 ustar 00 #! /usr/bin/perl
# debhelper sequence file for dh_python2
use warnings;
use strict;
use Debian::Debhelper::Dh_Lib;
insert_after("dh_perl", "dh_python2");
remove_command("dh_pycentral");
remove_command("dh_pysupport");
1
Debian/DebConf/Client/ConfModule.pm 0000666 00000001142 15077711155 0013050 0 ustar 00 #!/usr/bin/perl
# This is a stub module that just uses the new module, and is here for
# backwards-compatability with pograms that use the old name.
package Debian::DebConf::Client::ConfModule;
use Debconf::Client::ConfModule;
use Debconf::Log qw{debug};
print STDERR "Debian::DebConf::Client::ConfModule is deprecated, please use Debconf::Client::ConfModule instead.\n";
sub import {
splice @_, 0, 1 => Debconf::Client::ConfModule;
goto &{Debconf::Client::ConfModule->can('import')};
}
sub AUTOLOAD {
(my $sub = $AUTOLOAD) =~ s/.*:://;
*$sub = \&{"Debconf::Client::ConfModule::$sub"};
goto &$sub;
}
1
Debian/DictionariesCommon.pm 0000666 00000045703 15077711155 0012100 0 ustar 00 #!/usr/bin/perl
package Debian::DictionariesCommon;
use base qw(Exporter);
use Text::Iconv;
# List all exported symbols here.
our @EXPORT_OK = qw(parseinfo updatedb loaddb
dico_checkroot
dico_get_spellchecker_params
getlibdir
dico_getsysdefault dico_setsysdefault
getuserdefault setuserdefault
build_emacsen_support
build_jed_support
build_squirrelmail_support
);
# Import :all to get everything.
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
my $infodir = "/var/lib/dictionaries-common";
my $cachedir = "/var/cache/dictionaries-common";
my $etcdir = "/etc/dictionaries-common";
my $ispelldefault = "ispell-default";
my $userdefault = ( defined $ENV{HOME} ) ? "$ENV{HOME}/.$ispelldefault" : undef;
my $emacsensupport = "emacsen-ispell-dicts.el";
my $jedsupport = "jed-ispell-dicts.sl";
my $squirrelmailsupport = "sqspell.php";
my %sysetcdefault = ("ispell" => "$etcdir/ispell-default",
"wordlist" => "$etcdir/wordlist-default");
sub dico_checkroot {
return if ($> == 0 or ($^O eq 'interix' and $> == 197108));
die "$0: You must run this as root.\n";
}
sub getlibdir {
my $class = shift;
return "$infodir/$class";
}
sub mydie {
my $routine = shift;
my $errmsg = shift;
die __PACKAGE__, "($routine):E: $errmsg";
}
sub parseinfo {
my $file = shift;
local $/ = ""; # IRS is global, we need 'local' here, not 'my'
open (DICT, "< $file");
my %dictionaries =
map {
s/^([^:]+):/lc ($1) . ":"/meg; # Lower case field names
my %hash = /^([^:]+):\s*((?;
return \%dictionaries;
}
# ------------------------------------------------------------------
sub dico_dumpdb {
# ------------------------------------------------------------------
# Save %dictionaries in Data::Dumper like format. This function
# should be enough for the limited needs of dictionaries-common
# ------------------------------------------------------------------
my $class = shift;
my $dictionaries = shift;
my @fullarray = ();
my @dictarray = ();
my $output = "$cachedir/$class.db";
my $dictentries = '';
my $thevalue = '';
foreach $thedict ( sort keys %{$dictionaries}){
$dictentries = $dictionaries->{$thedict};
@dictarray = ();
foreach $thekey ( sort keys %{$dictentries}){
$thevalue = $dictentries->{$thekey};
# Make sure \ and ' are escaped in keyvals
$thevalue =~ s/(\\|\')/\\$1/g;
push (@dictarray," \'$thekey\' => \'$thevalue\'");
}
# Make sure \ and ' are escaped in dict names
$thedict =~ s/(\\|\')/\\$1/g;
push (@fullarray,
" \'$thedict\' => \{\n" . join(",\n",@dictarray) . "\n \}");
}
mkdir $cachedir unless (-d $cachedir);
open (DB,"> $output");
print DB generate_comment("### ") . "\n";
print DB "%dictionaries = (\n";
print DB join (",\n",@fullarray);
print DB "\n);\n\n1;\n";
close DB;
}
# ------------------------------------------------------------------
sub dico_get_spellchecker_params {
# ------------------------------------------------------------------
# dico_get_spellchecker_params($class,\%language)
# Get right params for $class (currently unused) and $language
# ------------------------------------------------------------------
my $class = shift;
my $language = shift;
my $d_option = "";
my $w_option = "";
my $T_option = "";
my $ispell_args = "";
$d_option = "-d $language->{'hash-name'}"
if exists $language->{'hash-name'};
$w_option = "-w $language->{'additionalchars'}"
if exists $language->{'additionalchars'};
if ( exists $language->{'extended-character-mode'} ){
$T_option = $language->{'extended-character-mode'};
$T_option =~ s/^~//; # Strip leading ~ from Extended-Character-Mode.
$T_option = '-T ' . $T_option;
}
if ( exists $language->{'ispell-args'} ){
$ispell_args = $language->{'ispell-args'};
foreach ( split('\s+',$ispell_args) ) {
# No d_option if already in $ispell_args
$d_option = "" if /^\-d/;
}
}
return "$d_option $w_option $T_option $ispell_args";
}
# ------------------------------------------------------------------
sub updatedb {
# ------------------------------------------------------------------
# Parse info files for the given class and update class database
# ------------------------------------------------------------------
my $class = shift;
my %dictionaries = ();
foreach my $file (<$infodir/$class/*>) {
next if $file =~ m/.*~$/; # Ignore ~ backup files
my $dicts = &parseinfo ("$file");
%dictionaries = (%dictionaries, %$dicts);
}
&dico_dumpdb($class,\%dictionaries);
}
# ------------------------------------------------------------------
sub loaddb {
# ------------------------------------------------------------------
# Load class database
# ------------------------------------------------------------------
my $class = shift;
my $dbfile = "$cachedir/$class.db";
if (-e $dbfile) {
do $dbfile;
}
return \%dictionaries;
}
# ------------------------------------------------------------------
sub getdefault {
# ------------------------------------------------------------------
# If available, read current user's default from given file.
# ------------------------------------------------------------------
$file = shift;
if (-f $file) {
my $lang = `cat $file`;
chomp $lang;
return $lang;
}
else {
return undef;
}
}
# ------------------------------------------------------------------
sub getuserdefault {
# ------------------------------------------------------------------
# Get user default from user's default file
# ------------------------------------------------------------------
die "Dictionaries-common::getuserdefault: Could not set \$userdefault. Aborting ...\n"
unless $userdefault;
getdefault ($userdefault);
}
# ------------------------------------------------------------------
sub dico_getsysdefault {
# ------------------------------------------------------------------
# Get system default value for given class
# ------------------------------------------------------------------
my $class = shift;
getdefault ($sysetcdefault{$class});
}
# ------------------------------------------------------------------
sub dico_setsysdefault {
# ------------------------------------------------------------------
# Set system default value for given class
# ------------------------------------------------------------------
my $class = shift;
my $value = shift;
open (DEFAULT, "> $sysetcdefault{$class}");
print DEFAULT $value;
close DEFAULT;
}
# ------------------------------------------------------------------
sub setuserdefault {
# ------------------------------------------------------------------
# Write user's default value to user's default file
# ------------------------------------------------------------------
my $default = getuserdefault ();
my $dictionaries = loaddb ("ispell");
my @choices = sort keys %$dictionaries;
if (scalar @choices == 0) {
warn "Sorry, no ispell dictionary is installed in your system.\n";
return;
}
my $initial = -1;
if (defined $default) {
for (my $i = 0; $i < scalar @choices; $i++) {
if ($default eq $choices[$i]) {
$initial = $i;
last;
}
}
}
open (TTY, "/dev/tty");
while (1) {
$| = 1;
print
"\nSelect your personal ispell dictionary for use with ispell-wrapper\n\n";
for ($i = 0; $i < scalar @choices; $i++) {
print " " . ($i == $initial ? "*" : " ")
. " [" . ($i+1) . "] $choices[$i]\n";
}
print qq(\nSelect number or "q" for quit)
. ($initial != -1 ? " (* is the current default): " : ": ");
my $sel = ;
chomp $sel;
last if $sel eq "q";
if ($sel < 1 or $sel > scalar @choices) {
print qq{\nInvalid choice "$sel".\n\n};
next;
}
else {
$sel--;
open (DEFAULT, "> $userdefault");
print DEFAULT $choices[$sel];
close DEFAULT;
last;
}
}
close TTY;
}
sub generate_comment {
my $commstr = shift;
my $comment = "This file is part of the dictionaries-common package.
It has been automatically generated.
DO NOT EDIT!";
$comment =~ s{^}{$commstr}mg;
return "$comment\n";
}
# ------------------------------------------------------------------
sub build_emacsen_support {
# ------------------------------------------------------------------
# Put info from dicts info files into emacsen-ispell-dicts.el
# ------------------------------------------------------------------
my $elisp = '';
my @classes = ("aspell","hunspell","ispell");
my %entries = ();
my %class_locales = ();
foreach $class ( @classes ){
my $dictionaries = loaddb ($class);
foreach $k (keys %$dictionaries) {
my $lang = $dictionaries->{$k};
next if (exists $lang->{'emacs-display'}
&& $lang->{'emacs-display'} eq "no");
my $hashname = $lang->{"hash-name"};
my $casechars = exists $lang->{casechars} ?
$lang->{casechars} : "[a-zA-Z]";
my $notcasechars = exists $lang->{"not-casechars"} ?
$lang->{"not-casechars"} : "[^a-zA-Z]";
my $otherchars = exists $lang->{otherchars} ?
$lang->{otherchars} : "[']";
my $manyothercharsp = exists $lang->{"many-otherchars"} ?
($lang->{"many-otherchars"} eq "yes" ? "t" : "nil") : "nil";
my $ispellargs = exists $lang->{"ispell-args"} ?
$lang->{"ispell-args"} : "-d $hashname";
my $extendedcharactermode = exists $lang->{"extended-character-mode"} ?
('"' . $lang->{"extended-character-mode"} . '"') : "nil";
my $codingsystem = exists $lang->{"coding-system"} ?
$lang->{"coding-system"} : "nil";
my $emacsenname = exists $lang->{"emacsen-name"} ?
$lang->{"emacsen-name"} : $hashname;
# Explicitly add " -d $hashname" to $ispellargs if not already there.
# Note that this must check for "-dxx", "-d xx", "-C -d xx", "-C -dxx" like matches
if ( $ispellargs !~ m/( |^)-d/ ){
print STDERR " - $class-emacsen: Adding \" -d $hashname\" to \"$ispellargs\"\n"
if defined $ENV{'DICT_COMMON_DEBUG'};
$ispellargs .= " -d $hashname";
}
$entries{$class}{$emacsenname} = $entries{'all'}{$emacsenname} =
['"' . $emacsenname . '"',
'"' . $casechars . '"',
'"' . $notcasechars . '"',
'"' . $otherchars . '"',
$manyothercharsp,
'("' . join ('" "', split (/\s+/,$ispellargs)) . '")',
$extendedcharactermode,
$codingsystem];
if ( $class eq "aspell" && exists $lang->{"aspell-locales"} ){
foreach ( split(/\s*,\s*/,$lang->{"aspell-locales"}) ){
$class_locales{"aspell"}{$_} = $emacsenname;
}
} elsif ( $class eq "hunspell" && exists $lang->{"hunspell-locales"} ){
foreach ( split(/\s*,\s*/,$lang->{"hunspell-locales"}) ){
$class_locales{"hunspell"}{$_} = $emacsenname;
}
}
}
}
# Write alists of ispell, hunspell and aspell only installed dicts and their properties
foreach $class ( @classes ) {
my @class_dicts = reverse sort keys %{ $entries{$class} };
if ( scalar @class_dicts ){
$elisp .= "\n;; Adding $class dicts\n\n";
foreach ( @class_dicts ){
my $mystring = join ("\n ",@{ $entries{$class}{$_} });
$elisp .= "(add-to-list \'debian-$class-only-dictionary-alist\n \'($mystring))\n";
}
$elisp .= "\n";
}
}
# Write a list of locales associated to each emacsen name
foreach my $class ("aspell", "hunspell"){
my $tmp_locales = $class_locales{$class};
if ( defined $tmp_locales && scalar %$tmp_locales ){
$elisp .= "\n\n;; An alist that will try to map $class locales to emacsen names";
$elisp .= "\n\n(setq debian-$class-equivs-alist \'(\n";
foreach ( sort keys %$tmp_locales ){
$elisp .= " (\"$_\" \"$tmp_locales->{$_}\")\n";
}
$elisp .= "))\n";
# Obtain here debian-aspell-dictionary, after debian-aspell-equivs-alist
# is loaded
$elisp .="
;; Get default value for debian-$class-dictionary. Will be used if
;; spellchecker is $class and ispell-local-dictionary is not set.
;; We need to get it here, after debian-$class-equivs-alist is loaded
(setq debian-$class-dictionary (debian-ispell-get-$class-default))\n\n";
} else {
$elisp .= "\n\n;; No emacsen-$class-equivs entries were found\n";
}}
open (ELISP, "> $cachedir/$emacsensupport")
or die "Cannot open emacsen cache file";
print ELISP generate_comment (";;; ");
print ELISP $elisp;
close ELISP;
}
# ------------------------------------------------------------------
sub build_jed_support {
# ------------------------------------------------------------------
# Put info from dicts info files into jed-ispell-dicts.sl
# ------------------------------------------------------------------
my @classes = ("aspell","ispell");
my $slang = generate_comment ("%%% ");
## The S-Lang code generated below will be wrapped in preprocessor
## ifexists constructs, insuring that the $jedsupport file will
## always evaluate correctly.
foreach $class ( @classes ){
my %class_slang = ();
my %class_slang_u8 = ();
if ( my $dictionaries = loaddb ($class) ){
foreach $k (sort keys %$dictionaries) {
my $lang = $dictionaries->{$k};
next if (exists $lang->{'jed-display'}
&& $lang->{'jed-display'} eq "no");
my $hashname = $lang->{"hash-name"};
my $additionalchars = exists $lang->{additionalchars} ?
$lang->{additionalchars} : "";
my $otherchars = exists $lang->{otherchars} ?
$lang->{otherchars} : "'";
my $emacsenname = exists $lang->{"emacsen-name"} ?
$lang->{"emacsen-name"} : $hashname;
my $extendedcharmode = exists $lang->{"extended-character-mode"} ?
$lang->{"extended-character-mode"} : "";
my $ispellargs = exists $lang->{"ispell-args"} ?
$lang->{"ispell-args"} : "";
my $codingsystem = exists $lang->{"coding-system"} ?
$lang->{"coding-system"} : "l1";
# Strip enclosing [] from $otherchars
$otherchars =~ s/^\[//;
$otherchars =~ s/\]$//;
# Convert chars in octal \xxx representation to the character
$otherchars =~ s/\\([0-3][0-7][0-7])/chr(oct($1))/ge;
$additionalchars =~ s/\\([0-3][0-7][0-7])/chr(oct($1))/ge;
$class_slang{$emacsenname} =
" $class" . "_add_dictionary (\n"
. " \"$emacsenname\",\n"
. " \"$hashname\",\n"
. " \"$additionalchars\",\n"
. " \"$otherchars\",\n"
. ($class eq "ispell" ? " \"$extendedcharmode\",\n" : "")
. " \"$ispellargs\");";
if ( $class eq "aspell" ){
my $converter = Text::Iconv->new ($codingsystem, "utf8");
my $additionalchars_utf = $converter->convert ($additionalchars);
my $otherchars_utf = $converter->convert ($otherchars);
$class_slang_u8{$emacsenname} =
qq{ aspell_add_dictionary (
"$emacsenname",
"$hashname",
"$additionalchars_utf",
"$otherchars_utf",
"$ispellargs");};
} # if $class ..
} # foreach $k ..
} # if loaddb ..
if ( scalar keys %class_slang ){
$slang .= "\n\#ifexists $class" . "_add_dictionary\n";
if ( $class eq "aspell" ){
$slang .= " if (_slang_utf8_ok) {\n"
. join("\n",sort values %class_slang_u8)
. "\n } else {\n"
. join("\n",sort values %class_slang)
. "\n }";
} else {
$slang .= join("\n",sort values %class_slang);
}
$slang .= "\n\#endif\n";
}
} # foreach $class
open (SLANG, "> $cachedir/$jedsupport")
or die "Cannot open jed cache file";
print SLANG $slang;
close SLANG;
}
# ------------------------------------------------------------------
sub build_squirrelmail_support {
# ------------------------------------------------------------------
# Build support file for squirrelmail with a list of available
# dictionaries and associated spellchecker calls, in php format.
# ------------------------------------------------------------------
my @classes = ("aspell","ispell","hunspell");
my $php = "{$_};
my $squirrelname;
if ( defined $lang->{"squirrelmail"} ){
next if ( lc($lang->{"squirrelmail"}) eq "no" );
$squirrelname = $lang->{"squirrelmail"};
} else {
next unless m/^(.*)\((.+)\)$/;
$squirrelname = $2;
}
my $spellchecker_params =
&dico_get_spellchecker_params($class,$lang);
push @dictlist, qq { '$squirrelname ($class)' => '$class -a $spellchecker_params'};
}
}
$php .= join(",\n", sort @dictlist);
$php .= "\n);\n";
open (PHP, "> $cachedir/$squirrelmailsupport")
or die "Cannot open SquirrelMail cache file";
print PHP $php;
close PHP;
}
# Ensure we evaluate to true.
1;
__END__
#Local Variables:
#perl-indent-level: 2
#End:
=head1 NAME
Debian::DictionariesCommon.pm - dictionaries-common library
=head1 SYNOPSIS
use Debian::DictionariesCommon q(:all)
$dictionaries = parseinfo ('/var/lib/dictionaries-common/ispell/iwolof');
loaddb ('ispell')
updatedb ('wordlist')
=head1 DESCRIPTION
Common functions for use from the dictionaries-common system.
=head1 CALLING FUNCTIONS
=over
=item C
Check for rootness and fail if not.
=item C
Put info from dicts info files into emacsen-ispell-dicts.el
=item C
Put info from dicts info files into jed-ispell-dicts.sl
=item C
Build support file for squirrelmail with a list of available
dictionaries and associated spellchecker calls, in php format.
=item C<$libdir = getlibdir($class)>
Return info dir for given class.
=item C<$default = dico_getsysdefault($class)>
Return system default value for given class.
=item C<$libdir = getuserdefault>
Return value for user default ispell dictionary.
=item C
Get right params for $class (currently unused) and $language
=item C<\%dictionaries = loaddb($class)>
Read class .db file and return a reference to a hash
with its contents.
=item C<\%result = parseinfo($file)>
Parse given info file and return a reference to a hash with
the relevant data.
=item C
Set value for system default ispell dictionary.
=item C
Set value for user default ispell dictionary, after asking
to select it from the available values.
=item C
Parse info files for given class and update class .db
file under dictionaries-common cache dir.
=back
=head1 SEE ALSO
Debian dictionaries-common policy.
=head1 AUTHORS
Rafael Laboissiere
Agustin Martin
=cut
Debian/Defoma/IdCache.pm 0000666 00000016733 15077711155 0010766 0 ustar 00 package Debian::Defoma::IdCache;
use strict;
use POSIX;
use FileHandle;
my %TYPE = ( 'Sr' => 'real', 'SrI' => 'real',
'Sa' => 'alias', 'SaI' => 'alias',
'Ua' => 'alias', 'UaI' => 'alias',
'SS' => 'subst', 'SSI' => 'subst',
'Mu' => 'mark', 'Mx' => 'mark', 'MX' => 'mark' );
sub new {
my $class = shift;
my $o = {
0 => [],
1 => [],
2 => [],
3 => [],
4 => [],
5 => [],
6 => [],
7 => [],
real => {},
alias => {},
mark => {},
subst => {},
installed => {},
deleted => [],
g0 => {},
g1 => {},
hash01 => {},
hash01_mark => {},
hash0_installed => {},
hash5 => {},
hash6 => {},
file => shift,
cnt => 0,
pkg => shift,
suffix => shift,
unregistering => {},
delay => 0,
callback => 1
};
$o->{e_id} = $o->{0};
$o->{e_font} = $o->{1};
$o->{e_type} = $o->{2};
$o->{e_priority} = $o->{3};
$o->{e_category} = $o->{4};
$o->{e_depid} = $o->{5};
$o->{e_depfont} = $o->{6};
$o->{e_hints} = $o->{7};
$o->{g0}->{real} = {};
$o->{g0}->{alias} = {};
$o->{g0}->{subst} = {};
$o->{g0}->{mark} = {};
$o->{g1}->{real} = {};
$o->{g1}->{alias} = {};
$o->{g1}->{subst} = {};
$o->{g1}->{mark} = {};
$o->{g1}->{installed} = {};
bless $o;
return $o;
}
sub hash_add_install {
my ($o, $i, $k0, $k1) = @_;
$o->{installed}->{$i} = undef;
$o->{hash0_installed}->{$k0} = $i;
unless (exists($o->{g1}->{installed}->{$k1})) {
$o->{g1}->{installed}->{$k1} = {};
}
$o->{g1}->{installed}->{$k1}->{$i} = undef;
}
sub hash_add {
my ($o, $i, $k0, $k1, $k2, $k5, $k6) = @_;
my $type = $TYPE{$k2};
unless (exists($o->{g0}->{real}->{$k0})) {
$o->{g0}->{real}->{$k0} = {};
$o->{g0}->{alias}->{$k0} = {};
$o->{g0}->{subst}->{$k0} = {};
$o->{g0}->{mark}->{$k0} = {};
}
unless (exists($o->{g1}->{real}->{$k1})) {
$o->{g1}->{real}->{$k1} = {};
$o->{g1}->{alias}->{$k1} = {};
$o->{g1}->{subst}->{$k1} = {};
$o->{g1}->{mark}->{$k1} = {};
}
unless ($k5 eq '.') {
unless (exists($o->{hash5}->{$k5})) {
$o->{hash5}->{$k5} = {};
}
$o->{hash5}->{$k5}->{$i} = undef;
}
unless ($k6 eq '.') {
unless (exists($o->{hash6}->{$k6})) {
$o->{hash6}->{$k6} = {};
}
$o->{hash6}->{$k6}->{$i} = undef;
}
$o->{g0}->{$type}->{$k0}->{$i} = undef;
$o->{g1}->{$type}->{$k1}->{$i} = undef;
if ($k2 =~ /..I$/) {
$o->hash_add_install($i, $k0, $k1, $k2);
}
if ($type ne 'mark') {
$o->{$type}->{$i} = undef;
$o->{hash01}->{$k0.' '.$k1} = $i;
} else {
$o->{mark}->{$i} = undef;
$o->{hash01_mark}->{$k0.' '.$k1} = $i;
}
}
sub hash_remove_install {
my ($o, $i, $k0, $k1) = @_;
delete($o->{installed}->{$i});
delete($o->{hash0_installed}->{$k0});
delete($o->{g1}->{installed}->{$k1}->{$i});
}
sub hash_remove {
my ($o, $i) = @_;
my $k0 = $o->{0}->[$i];
my $k1 = $o->{1}->[$i];
my $k2 = $o->{2}->[$i];
my $k5 = $o->{5}->[$i];
my $k6 = $o->{6}->[$i];
my $type = $TYPE{$k2};
delete($o->{g0}->{$type}->{$k0}->{$i});
delete($o->{g1}->{$type}->{$k1}->{$i});
delete($o->{hash5}->{$k5}->{$i}) unless ($k5 eq '.');
delete($o->{hash6}->{$k6}->{$i}) unless ($k6 eq '.');
if ($k2 =~ /..I$/) {
$o->hash_remove_install($i, $k0, $k1);
}
if ($type ne 'mark') {
delete($o->{$type}->{$i});
delete($o->{hash01}->{$k0.' '.$k1});
} else {
delete($o->{mark}->{$i});
delete($o->{hash01_mark}->{$k0.' '.$k1});
}
}
sub read {
my $o = shift;
my $file = $o->{file};
my $i = 0;
my $j;
my $type;
my $fh = new FileHandle($o->{file}, "r");
if (defined($fh)) {
while(<$fh>) {
chomp($_);
my @list = split(' ', $_);
my ($k0, $k1, $k2, $k5, $k6);
# code to keep backword compatibility.
if ($list[2] eq 'Ir' || $list[2] eq 'Ia' || $list[2] eq 'IS') {
if (exists($o->{hash01}->{$list[0].' '.$list[1]})) {
$j = $o->{hash01}->{$list[0].' '.$list[1]};
$o->{2}->[$j] .= 'I';
$o->hash_add_install($j, $list[0], $list[1]);
}
next;
}
# fallback for the code above.
if ($list[2] =~ /^M.I$/) {
next;
}
# fallback for broken id-cache.
next if (@list < 7);
$o->{0}->[$i] = $k0 = shift(@list);
$o->{1}->[$i] = $k1 = shift(@list);
$o->{2}->[$i] = $k2 = shift(@list);
$o->{3}->[$i] = shift(@list);
$o->{4}->[$i] = shift(@list);
$o->{5}->[$i] = $k5 = shift(@list);
$o->{6}->[$i] = $k6 = shift(@list);
$o->{7}->[$i] = (@list > 0) ? join(' ', @list) : '';
$o->hash_add($i, $k0, $k1, $k2, $k5, $k6);
$i++;
}
$fh->close();
}
$o->{cnt} = $i;
return 0;
}
sub write {
my $o = shift;
my $file = $o->{file};
my $max = $o->{cnt};
my ($i, $j);
my $fh = new FileHandle($o->{file}, "w");
if (defined($fh)) {
for ($i = 0; $i < $max; $i++) {
$j = $o->{0}->[$i];
if ($j ne '') {
$fh->print($j, ' ', $o->{1}->[$i], ' ', $o->{2}->[$i], ' ',
$o->{3}->[$i], ' ', $o->{4}->[$i], ' ',
$o->{5}->[$i], ' ', $o->{6}->[$i], ' ',
$o->{7}->[$i], "\n");
}
}
$fh->close();
}
unlink($file) unless(-s $file);
return 0;
}
sub grep {
my $o = shift;
my $t = shift;
my %op = @_;
my @pat = ();
my @idx = ();
my ($i, $j, $k, $ii, $max, $or, $match, $pmax);
my @nul = ();
my @lines = ();
my @ret = ();
my $gflag = 0;
$or = 0;
$pmax = 0;
foreach $i (keys(%op)) {
if ($i eq 'or') {
$or = 1;
} elsif ($i =~ /(.)(.)/) {
$ii = $2;
$ii += 8 if ($1 eq 'r');
$j = $op{$i};
if ($ii <= 1) {
my $gn = 'g'.$ii;
$gflag = 1;
if ($t eq 'font') {
if (exists($o->{$gn}->{real}->{$j})) {
@lines = (keys(%{$o->{$gn}->{real}->{$j}}),
keys(%{$o->{$gn}->{alias}->{$j}}),
keys(%{$o->{$gn}->{subst}->{$j}}));
} else {
return @nul;
}
} else {
if (exists($o->{$gn}->{$t}->{$j})) {
@lines = keys(%{$o->{$gn}->{$t}->{$j}});
} else {
return @nul;
}
}
} else {
$idx[$pmax] = $ii;
$pat[$pmax] = $j;
$pmax++;
}
}
}
if ($gflag == 0) {
if ($t eq 'font') {
@lines = (keys(%{$o->{real}}), keys(%{$o->{alias}}),
keys(%{$o->{subst}}));
} else {
@lines = keys(%{$o->{$t}});
}
}
if ($pmax == 0) {
return @lines;
}
foreach $i (@lines) {
next unless ($o->{0}->[$i]);
$match = 1;
for ($j = 0; $j < $pmax; $j++) {
$match = 0;
$ii = $idx[$j];
if ($ii >= 8) {
$ii -= 8;
$match = 1 if ($o->{$ii}->[$i] =~ /$pat[$j]/);
} else {
$match = 1 if ($o->{$ii}->[$i] eq $pat[$j]);
}
if ($or) {
last if ($match);
} else {
last if ($match == 0);
}
}
push(@ret, $i) if ($match);
}
return @ret;
}
sub add {
my $o = shift;
my $j = 0;
my $i;
if (@{$o->{deleted}} > 0) {
$i = pop(@{$o->{deleted}});
} else {
$i = $o->{cnt};
$o->{cnt}++;
}
$o->hash_add($i, $_[0], $_[1], $_[2], $_[5], $_[6]);
my $font = shift;
for ($j = 1; $j < 8; $j++) {
$o->{$j}->[$i] = shift;
}
$o->{0}->[$i] = $font;
return $i;
}
sub delete {
my $o = shift;
foreach my $i (@_) {
$o->hash_remove($i);
$o->{0}->[$i] = '';
push(@{$o->{deleted}}, $i);
}
return 0;
}
sub install {
my $o = shift;
my $i = shift;
$o->{2}->[$i] .= 'I';
$o->hash_add_install($i, $o->{0}->[$i], $o->{1}->[$i]);
}
sub uninstall {
my $o = shift;
my $i = shift;
$o->{2}->[$i] =~ s/I$//;
$o->hash_remove_install($i, $o->{0}->[$i], $o->{1}->[$i]);
}
1;
Debian/Defoma/Font.pm 0000666 00000010430 15077711155 0010400 0 ustar 00 package Debian::Defoma::Font;
use strict;
use POSIX;
use Exporter;
use vars qw(@EXPORT @ISA %Fobjs $Userspace);
use Debian::Defoma::Common;
import Debian::Defoma::Common qw(&arg_check &arg_check_category &get_files);
use Debian::Defoma::FontCache;
@ISA = qw(Exporter);
@EXPORT = qw(&defoma_font_init &defoma_font_register &defoma_font_unregister
&defoma_font_reregister &defoma_font_term
&defoma_font_if_register &defoma_font_get_fonts
&defoma_font_get_hints &defoma_font_get_failed
&defoma_font_get_object);
%Fobjs = ();
$Userspace = 1;
sub defoma_font_init {
%Fobjs = ();
&Debian::Defoma::FontCache::initialize(ROOTDIR);
my @list = get_files("\\.font-cache\$", ROOTDIR);
my $o;
my $i;
foreach $i (@list) {
$i =~ s/\.font-cache$//;
$o = new Debian::Defoma::FontCache($i);
$o->read();
$Fobjs{$i} = $o;
}
return 0;
}
sub defoma_font_check_font {
my $font = shift;
my @list = values(%Fobjs);
foreach my $fobj (@list) {
if (exists($fobj->{cache_list}->{$font})) {
return $fobj->{category};
}
}
return '';
}
sub defoma_font_get_object {
my $category = shift;
unless (exists($Fobjs{$category})) {
my $fo = $Fobjs{$category} = new Debian::Defoma::FontCache($category);
}
return $Fobjs{$category};
}
sub defoma_font_register {
my $category = shift;
my $font = shift;
my @hints = @_;
arg_check($font, $category) || return 1;
arg_check_category($category) || return 1;
my $fobj;
if (exists($Fobjs{$category})) {
$fobj = $Fobjs{$category};
} else {
$fobj = $Fobjs{$category} = new Debian::Defoma::FontCache($category);
}
my $s = defoma_font_check_font($font);
if ($s ne '') {
printw("$font: already registered in category $s.");
return 1;
}
$fobj->add_font($font, @hints);
$fobj->add_user($font) if (USERSPACE && $Userspace);
$Userspace = 1;
printv("Registering $font..");
&Debian::Defoma::Configure::call_m($fobj, 'register', $category, $font,
@hints);
return 0;
}
sub defoma_font_unregister {
my $category = shift;
my $font = shift;
my $fobj;
unless (exists($Fobjs{$category})) {
printw("$category: Category not found.");
return 1;
}
$fobj = $Fobjs{$category};
unless (exists($fobj->{cache_list}->{$font})) {
printw("$font: not registered.");
return 1;
}
my @hints = split(' ', $fobj->{cache_list}->{$font});
printv("Unregistering $font..");
&Debian::Defoma::Configure::call_m($fobj, 'unregister', $category, $font,
@hints);
$fobj->remove_font($font);
$fobj->remove_user($font) if (USERSPACE);
return 0;
}
sub defoma_font_reregister {
my $category = shift;
my $font = shift;
my @hints0;
my $c = defoma_font_check_font($font);
if ($c ne '') {
if ($c eq $category) {
@hints0 = defoma_font_get_hints($c, $font);
if (@hints0 == @_) {
my $i = 0;
while ($i < @hints0 && $i < @_) {
last if ($hints0[$i] ne $_[$i]);
$i++;
}
return 0 if ($i == @_);
}
}
defoma_font_unregister($c, $font);
}
my $r = defoma_font_register($category, $font, @_);
return $r;
}
sub defoma_font_term {
my $fobj;
my @list = values(%Fobjs);
foreach $fobj (@list) {
$fobj->write();
}
return 0;
}
sub defoma_font_if_register {
my $category = shift;
my $font = shift;
if (exists($Fobjs{$category})) {
return 1 if (exists($Fobjs{$category}->{cache_list}->{$font}));
}
return 0;
}
sub defoma_font_get_fonts {
my $category = shift;
my @ret = ();
if (exists($Fobjs{$category})) {
my $fobj = $Fobjs{$category};
@ret = keys(%{$fobj->{cache_list}});
}
return @ret;
}
sub defoma_font_get_hints {
my $category = shift;
my $font = shift;
my @ret = ();
if (exists($Fobjs{$category})) {
my $fobj = $Fobjs{$category};
if (exists($fobj->{cache_list}->{$font})) {
@ret = split(' ', $fobj->{cache_list}->{$font});
}
}
return @ret;
}
sub defoma_font_get_failed {
my $category = shift;
my $font = shift;
my %ret = ();
if (exists($Fobjs{$category})) {
my $fobj = $Fobjs{$category};
if (exists($fobj->{fcache_list}->{$font})) {
%ret = %{$fobj->{fcache_list}->{$font}};
}
}
return %ret;
}
1;
Debian/Defoma/Common.pm 0000666 00000063771 15077711155 0010742 0 ustar 00 package Debian::Defoma::Common;
use strict;
use POSIX;
use Exporter;
use FileHandle;
use vars qw(@EXPORT @EXPORT_OK @ISA $ROOTDIR $DEFOMA_TEST_DIR
$DEFAULT_PACKAGE $DEFAULT_CATEGORY);
my ($Scriptdir, $Substruledir, $Homedir, $Lockfile, $Quiet, $Error, $Verbose,
$Debug, $Userspace, @Scriptdirs, $Locale, $Login);
my ($Defoma_Test_Dir, $Rootdir);
my $Version = "0.10.0";
my @Args;
my @Options;
BEGIN {
@ISA = qw(Exporter);
@EXPORT = qw(&printm &printw &printe &printv &printd &add_hash_list
&parse_hints_start
&parse_hints_cut &parse_hints_cut_except &parse_hints_build
&parse_hints_subhints &parse_hints_subhints_inherit
&get_xencoding &get_charset
&weight_a2i &weight_ascii2integer
&get_xlfd_of_font
&app_readfile &app_writefile &app_symlink &app_unlink
$DEFOMA_TEST_DIR $ROOTDIR
&DEFOMA_TEST_DIR &ROOTDIR &USERSPACE &HOMEDIR &LOCALE
&SCRIPTDIR &SUBSTRULEDIR &LOCKFILE &ERROR
&SCRIPTDIRS &VERSION &ARGS &USERLOGIN &OPTIONS
);
@EXPORT_OK = qw(&mylock ®ister_id_object ®ister_subst_object
&get_id_object &get_subst_object &get_system_categories
&get_files &diff_files &arg_check &arg_check_category
&readfile &writefile
$DEFAULT_PACKAGE $DEFAULT_CATEGORY
);
$Quiet = 0;
$Error = 0;
$Verbose = 0;
$Debug = 0;
$Userspace = 0;
my @unknown = ();
@Args = @ARGV;
while (@ARGV > 0 && $ARGV[0] =~ /^-/ && $ARGV[0] !~ /^--/) {
my $options = shift(@ARGV);
$options =~ s/^-//;
my %h = (q => \$Quiet, t => \$Error, v => \$Verbose, d => \$Debug,
u => \$Userspace);
foreach my $option (split(//, $options)) {
if (my $s = $h{$option}) {
$$s = 1;
push(@Options, '-' . $option);
} else {
push(@unknown, '-' . $option);
}
}
}
$Error = 1 - $Error;
unshift(@ARGV, @unknown);
$Defoma_Test_Dir = $DEFOMA_TEST_DIR = '';
if ($Debug) {
if (exists($ENV{'DEFOMA_TEST_DIR'})) {
$Defoma_Test_Dir = $DEFOMA_TEST_DIR = $ENV{'DEFOMA_TEST_DIR'};
}
push(@Scriptdirs, "$DEFOMA_TEST_DIR/usr/local/share/defoma/scripts");
}
push(@Scriptdirs, "$DEFOMA_TEST_DIR/usr/share/defoma/scripts");
if (exists($ENV{'LC_ALL'})) {
$Locale = $ENV{'LC_ALL'};
} elsif (exists($ENV{'LANG'})) {
$Locale = $ENV{'LANG'};
} else {
$Locale = '';
}
$Homedir = '';
if ($Userspace) {
my @l = getpwuid($<);
$Homedir = "$DEFOMA_TEST_DIR$l[7]";
$Login = $l[0];
$Rootdir = $ROOTDIR = "$Homedir/.defoma";
} else {
$Rootdir = $ROOTDIR = "$DEFOMA_TEST_DIR/var/lib/defoma";
}
$Substruledir = "$DEFOMA_TEST_DIR/etc/defoma";
$Scriptdir = "$ROOTDIR/scripts";
$Lockfile = "$ROOTDIR/locked";
$DEFAULT_PACKAGE = $DEFAULT_CATEGORY = '';
}
sub OPTIONS {
return @Options;
}
sub ARGS {
return @Args;
}
sub DEFOMA_TEST_DIR {
return $Defoma_Test_Dir;
}
sub ROOTDIR {
return $Rootdir;
}
sub SCRIPTDIR {
return $Scriptdir;
}
sub SCRIPTDIRS {
return @Scriptdirs;
}
sub SUBSTRULEDIR {
return $Substruledir;
}
sub HOMEDIR {
return $Homedir;
}
sub LOCKFILE {
return $Lockfile;
}
sub QUIET {
return $Quiet;
}
sub ERROR {
return $Error;
}
sub LOCALE {
return $Locale;
}
sub USERSPACE {
return $Userspace;
}
sub VERSION {
return $Version;
}
sub USERLOGIN {
return $Login;
}
sub printd {
return unless ($Debug);
my @c = caller(0);
print STDERR $c[3], " at line ", $c[2], " in ", $c[1], ": ", @_, "\n";
}
sub printm {
return if ($Quiet);
print STDERR @_, "\n";
}
my $CALLERLEVEL = 0;
sub printw {
print "W: ", @_, "\n";
}
sub printe {
print "E: ", @_, "\n";
}
sub printee {
my @c = caller($CALLERLEVEL);
$CALLERLEVEL = 0;
print STDERR $c[3], " at line ", $c[2], " in ", $c[1], ": ", @_, "\n";
}
sub printv {
return unless ($Verbose);
print @_, "\n";
}
sub get_files {
my $pattern = shift;
my $directory = shift;
my $i;
my @caches = ();
my @list;
opendir(D, $directory) || return ();
@list = readdir(D);
closedir(D);
foreach $i (@list) {
if ($i =~ /$pattern/) {
push(@caches, $i);
}
}
return @caches;
}
sub diff_files {
my $file1 = shift;
my $file2 = shift;
return 1 if ((-s $file1) != (-s $file2));
my $err = system("/usr/bin/cmp", "-s", $file1, $file2);
return $err;
}
sub arg_check {
my @b = @_;
while (@_ > 0) {
my $s = shift;
if ($s =~ /[ \t]/ || $s eq '') {
$CALLERLEVEL = 2;
printee "(", join(', ', @b), "): Illegal argument.";
return 0;
}
}
return 1;
}
sub arg_check_category {
while (@_ > 0) {
my $s = shift;
if ($s !~ /^[A-Za-z0-9-]+$/) {
$CALLERLEVEL = 2;
printee "'$s': Illegal Category name.";
return 0 ;
}
}
return 1;
}
sub add_hash_list {
my $hashptr = shift;
my $key = shift;
my $str = shift;
if (exists($hashptr->{$key})) {
$hashptr->{$key} .= ' ';
} else {
$hashptr->{$key} = '';
}
$hashptr->{$key} .= $str;
}
sub mylock {
my $flag = 0;
my $op = shift;
my $bg = (@_ > 0) ? shift(@_) : '';
if (USERSPACE) {
mkdir(ROOTDIR) unless (-d ROOTDIR);
mkdir(SCRIPTDIR) unless (-d SCRIPTDIR);
if ((-e ROOTDIR && ! -d ROOTDIR) || -l ROOTDIR) {
printe("Defoma-root-dir " . ROOTDIR . " is occupied.");
exit ERROR;
}
if ((-e SCRIPTDIR && ! -d SCRIPTDIR) || -l SCRIPTDIR) {
printe("Script-dir " . SCRIPTDIR . " is occupied.");
exit ERROR;
}
}
if ($op == 0) {
unlink($Lockfile);
} elsif ($op == 1) {
symlink("locknow", $Lockfile) && return 0;
printe("$Lockfile exists.");
unless (USERSPACE) {
printe("Another defoma process seems running, or you aren't root.");
printe("If you are root and defoma process isn't running undoubtedly,");
printe("it is possible that defoma might have aborted.");
printe("Please run defoma-reconfigure -f to fix its broken status.");
exit ERROR;
} else {
printe("Another defoma process seems running, or defoma might ".
"have aborted.");
printe("Please run defoma-user reconfigure to fix its broken status.");
exit ERROR;
}
}
}
sub get_system_categories {
# update defoma-reconfigure too.
return ('x-postscript', 'postscript', 'xfont', 'pspreview', 'obsoleted');
}
###### IdObject And SubstObject
my %IdObject = ();
sub register_id_object {
my $o = shift;
my $pkg = shift;
my $suffix = shift;
$IdObject{"$pkg/$suffix"} = $o;
}
sub get_id_object {
my $pkg = shift;
my $suffix = shift;
if (exists($IdObject{"$pkg/$suffix"})) {
return $IdObject{"$pkg/$suffix"};
}
return '';
}
sub clear_id_object {
%IdObject = ();
}
my %SubstObject = ();
sub register_subst_object {
my $o = shift;
my $rulename = shift;
$SubstObject{$rulename} = $o;
}
sub get_subst_object {
my $rulename = shift;
if (exists($SubstObject{$rulename})) {
return $SubstObject{$rulename};
}
return '';
}
sub clear_subst_object {
%SubstObject = ();
}
###### Parsehints
sub parse_hints_start {
my $ret = {};
my $key = '';
my $addflag = 0;
foreach my $item (@_) {
if ($item =~ /^--(.*)/) {
if ($key && $addflag == 0) {
$ret->{$key} = '';
}
$key = $1;
$addflag = 0;
} elsif ($key) {
$addflag = 1;
add_hash_list($ret, $key, $item);
}
}
if ($key && $addflag == 0) {
$ret->{$key} = '';
}
return $ret;
}
sub parse_hints_subhints {
my $parsed = shift;
my $subnum = shift;
my $ret = {};
$subnum = '' if ($subnum == 0);
foreach my $k (keys(%{$parsed})) {
if ($k =~ /(.*[^0-9-])-?$subnum$/) {
$ret->{$1} = $parsed->{$k};
}
}
return $ret;
}
sub parse_hints_subhints_inherit {
my $parsed = shift;
my $subnum = shift;
my $ret = parse_hints_subhints($parsed, $subnum);
return $ret if ($subnum == 0 || ! exists($parsed->{Inherit}));
my @l = split(' ', $parsed->{Inherit});
foreach my $k (@l) {
unless (exists($ret->{$k})) {
$ret->{$k} = $parsed->{$k};
}
}
return $ret;
}
sub parse_hints_cut {
my $parsed = shift;
my $key;
foreach $key (@_) {
if (exists($parsed->{$key})) {
delete($parsed->{$key});
}
}
}
sub parse_hints_cut_except {
my $parsed = shift;
my $key;
my @l = keys(%{$parsed});
foreach $key (@l) {
unless (grep($_ eq $key, @_)) {
delete($parsed->{$key});
}
}
}
sub parse_hints_build {
my $parsed = shift;
my $key;
my @keys = keys(%{$parsed});
my @ret = ();
foreach $key (@keys) {
push(@ret, '--' . $key);
push(@ret, split(' ', $parsed->{$key}));
}
return @ret;
}
###### File Handler ######
sub readfile {
my $file = shift;
my $fh = new FileHandle($file, "r");
my @ret = ();
if (defined($fh)) {
while (<$fh>) {
chomp($_);
push(@ret, $_);
}
$fh->close();
}
return @ret;
}
sub writefile {
my $file = shift;
my $fh = new FileHandle($file, "w");
if (defined($fh)) {
while (@_) {
$fh->print(shift, "\n");
}
$fh->close();
}
}
sub app_readfile {
my $file = shift;
return readfile("$Rootdir/$DEFAULT_PACKAGE.d/$file");
}
sub app_writefile {
my $file = shift;
return writefile("$Rootdir/$DEFAULT_PACKAGE.d/$file", @_);
}
sub app_symlink {
my $src = shift;
my $dest = shift;
return symlink($src, "$Rootdir/$DEFAULT_PACKAGE.d/$dest");
}
sub app_unlink {
my $file = shift;
return unlink("$Rootdir/$DEFAULT_PACKAGE.d/$file");
}
###### DataFile Handler ######
my @XencData;
sub read_csetenc_xenc_data {
my $dir = shift;
$dir .= "/csetenc-xenc.data2";
unless (@XencData) {
my @file = readfile($dir);
while (@file) {
my $a = shift(@file);
next if ($a =~ /^\#/);
my @l = split(/[ \t]+/, $a);
next if (@l < 3);
$l[0] =~ s/\*/\.\*/g;
$l[0] =~ s/\?/\./g;
$l[1] =~ s/\*/\.\*/g;
$l[1] =~ s/\?/\./g;
my $p = [];
$p->[0] = $l[0];
$p->[1] = $l[1];
$p->[2] = $l[2];
push(@XencData, $p);
}
}
}
sub get_xencoding {
my $charset = shift;;
my $encoding = shift || '';
unless (@XencData) {
read_csetenc_xenc_data("$DEFOMA_TEST_DIR/etc/defoma");
read_csetenc_xenc_data("$DEFOMA_TEST_DIR/usr/share/defoma");
}
foreach my $i (@XencData) {
if ($charset =~ /^($i->[0])$/ && $encoding =~ /^($i->[1])$/) {
if ($i->[2] eq 'ignore' || $i->[2] eq 'none') {
return '';
} else {
return $i->[2];
}
}
}
return '';
}
my @X2C;
sub read_xenc_cset_file {
my $dir = shift;
$dir .= "/xenc-cset.data";
my $i;
my @l;
my @file = readfile($dir);
while (@file) {
my $a = shift(@file);
next if ($a =~ /^\#/);
@l = split(' ', $a);
if (@l >= 2) {
$l[0] =~ s/\./\\./g;
$l[0] =~ s/\*/\.*/g;
$l[0] =~ s/\?/\./g;
push(@X2C, $l[0], $l[1]);
}
}
}
sub get_charset {
my $xfont = shift;
my $i;
unless (@X2C) {
read_xenc_cset_file("$DEFOMA_TEST_DIR/etc/defoma");
read_xenc_cset_file("$DEFOMA_TEST_DIR/usr/share/defoma");
}
$xfont =~ /([^-]+-[^-]+)$/;
my $xenc = $1;
for ($i = 0; $i < @X2C; $i += 2) {
return $X2C[$i + 1] if ($xenc =~ /^($X2C[$i])$/);
}
return '';
}
###### Weight -> Numeric ######
my %Weight2Numeric = ( Medium => 0,
Regular => 0,
Normal => 0,
Book => 0,
UltraBold => 4,
Ultrabold => 4,
ExtraBold => 3,
Extrabold => 3,
Bold => 2,
Semibold => 1,
DemiBold => 1,
Demibold => 1,
ExtraLight => -3,
Extralight => -3,
Light => -2,
SemiLight => -1,
Semilight => -1);
sub weight_a2i {
my $weight = shift;
return 0 unless ($weight);
exists($Weight2Numeric{$weight}) && return $Weight2Numeric{$weight};
$weight =~ tr/A-Z/a-z/;
my @l = keys(%Weight2Numeric);
foreach my $k (@l) {
my $j = $k;
$j =~ tr/A-Z/a-z/;
return $Weight2Numeric{$k} if ($j eq $weight);
}
return 0;
}
sub weight_ascii2integer {
return weight_a2i(@_);
}
###### get XLFD from x-ttcidfont-conf database ######
my ($XId, $XId2);
sub get_xlfd_of_font {
my $font = shift;
my %op = @_;
my $level = $op{level} || '';
my $face = $op{face};
unless ($XId) {
my $pkg = 'x-ttcidfont-conf';
$XId = &Debian::Defoma::Id::defoma_id_open_cache('', $pkg);
$XId2 = &Debian::Defoma::Id::defoma_id_open_cache('sub', $pkg);
return () unless ($XId && $XId2);
}
my @ret;
my @l = &Debian::Defoma::Id::defoma_id_grep_cache($XId, 'real',
font => $font);
foreach my $i (@l) {
next if ($XId->{2}->[$i] ne 'SrI');
my @hints = split(' ', $XId->{7}->[$i]);
my $ttcap = shift(@hints);
if (defined($face)) {
next if ($ttcap !~ /fn=$face/ && $ttcap !~ /:$face:/);
}
if ($level eq 'min') {
next if ($ttcap =~ /ds=y/ || $ttcap =~ /ai=/);
}
push(@ret, $XId->{0}->[$i]);
}
if ($level eq 'max') {
@l = &Debian::Defoma::Id::defoma_id_grep_cache($XId2, 'real',
font => $font);
foreach my $i (@l) {
next if ($XId2->{2}->[$i] ne 'SrI');
my @hints = split(' ', $XId2->{7}->[$i]);
my $ttcap = shift(@hints);
if (defined($face)) {
next if ($ttcap !~ /fn=$face/ && $ttcap !~ /:$face:/);
}
push(@ret, $XId2->{0}->[$i]);
}
}
return @ret;
}
package Debian::Defoma::Configure;
use strict;
#no strict 'subs';
use POSIX;
use File::Copy;
use vars qw(@ISA $DEFAULT_PACKAGE $DEFAULT_CATEGORY
@ACCEPT_CATEGORIES $APPINFO);
use Debian::Defoma::Common;
import Debian::Defoma::Common qw($DEFAULT_CATEGORY $DEFAULT_PACKAGE
&get_files &diff_files &readfile &writefile);
my %AppInfo = ();
my %Initialized = ();
my %Categories = ();
my @DefaultPackage = ();
my @DefaultCategory = ();
my %OriginalScripts;
my %RootScripts;
my %FontTouchTime;
my $UpdateTime;
sub read_status_cache {
my $rootdir = shift;
%FontTouchTime = ();
$UpdateTime = 0;
my @file = readfile($rootdir . "/status-cache");
while (@file) {
my @l = split(' ', shift(@file));
my $mode = shift(@l);
if ($mode eq 'font-last-modified') {
$FontTouchTime{$l[0]} = $l[1];
} elsif ($mode eq 'app-ignore') {
hash_app_info($l[0], 'ignore_category', $l[1], undef);
} elsif ($mode eq 'app-subdirs') {
push_app_info($l[0], 'subdirs', $l[1]);
} elsif ($mode eq 'app-links') {
push_app_info($l[0], 'links', $l[1].' '.$l[2]);
} elsif ($mode eq 'defoma-last-run') {
$UpdateTime = $l[0];
}
}
}
sub write_status_cache {
my $time = time();
my @file = ();
foreach my $fobj (values(%Debian::Defoma::Font::Fobjs)) {
my $c = $fobj->{category};
my $t = ($fobj->{updated} || ! $FontTouchTime{$c}) ?
$time : $FontTouchTime{$c};
push(@file, "font-last-modified $c $t");
}
foreach my $app (keys(%AppInfo)) {
if ($AppInfo{$app}->{ignore_category}) {
foreach my $i (keys(%{$AppInfo{$app}->{ignore_category}})) {
push(@file, "app-ignore $app $i");
}
}
if ($AppInfo{$app}->{subdirs}) {
foreach my $d (@{$AppInfo{$app}->{subdirs}}) {
push(@file, "app-subdirs $app $d") if ($d ne '');
}
}
if ($AppInfo{$app}->{links}) {
foreach my $l (@{$AppInfo{$app}->{links}}) {
push(@file, "app-links $app $l") if ($l ne '');
}
}
}
push(@file, "defoma-last-run $time");
writefile(ROOTDIR . "/status-cache", @file);
}
sub set_app_info {
my $app = shift;
my $key = shift;
my $value = shift;
unless (exists($AppInfo{$app})) {
$AppInfo{$app} = {};
}
$AppInfo{$app}->{$key} = $value;
}
sub push_app_info {
my $app = shift;
my $key = shift;
unless (exists($AppInfo{$app})) {
$AppInfo{$app} = {};
}
unless (exists($AppInfo{$app}->{$key})) {
$AppInfo{$app}->{$key} = [];
}
push(@{$AppInfo{$app}->{$key}}, @_);
}
sub hash_app_info {
my $app = shift;
my $key = shift;
my $hkey = shift;
my $hvalue = shift;
unless (exists($AppInfo{$app})) {
$AppInfo{$app} = {};
}
unless (exists($AppInfo{$app}->{$key})) {
$AppInfo{$app}->{$key} = {};
}
$AppInfo{$app}->{$key}->{$hkey} = $hvalue;
}
sub set_app_categories {
my $app = shift;
foreach my $i (@_) {
$Categories{$i} = [] unless (exists($Categories{$i}));
if ($app eq 'x-ttcidfont-conf' || $app eq 'psfontmgr') {
unshift(@{$Categories{$i}}, $app);
} else {
push(@{$Categories{$i}}, $app);
}
}
push_app_info($app, 'category', @_);
}
sub clear_app_info {
my $app = shift;
if (defined($app)) {
delete($AppInfo{$app});
} else {
%AppInfo = ();
}
}
sub get_app_info {
my $app = shift;
return $AppInfo{$app};
}
sub get_status {
my $fonttouchtime = shift;
my $updatetime = shift;
%{$fonttouchtime} = %FontTouchTime;
$$updatetime = $UpdateTime;
}
sub diff_scripts {
foreach my $app (keys(%OriginalScripts), keys(%RootScripts)) {
next if (exists($AppInfo{$app}->{script_change}));
if (! $RootScripts{$app} && $OriginalScripts{$app}) {
set_app_info($app, 'script_change', 'new');
} elsif ($RootScripts{$app} && ! $OriginalScripts{$app}) {
set_app_info($app, 'script_change', 'obsoleted');
set_app_info($app, 'ignoreall', 1);
printw("$app is already removed. ".
"It is recommended to run defoma-app purge $app.");
} else {
if (diff_files($RootScripts{$app}, $OriginalScripts{$app})) {
set_app_info($app, 'script_change', 'updated');
set_app_info($app, 'ignoreall', 1);
} else {
set_app_info($app, 'script_change', 'same');
}
}
}
return 0;
}
sub init_scripts {
# Check out /usr/share/defoma/scripts
my $pat = (USERSPACE) ? "\\.udefoma\$" : "\\.defoma\$";
my @scripts;
my $script;
%OriginalScripts = ();
foreach my $dir (SCRIPTDIRS) {
next unless (-d $dir);
@scripts = get_files($pat, $dir);
foreach $script (@scripts) {
my $app = $script;
$app =~ s/$pat//;
unless (exists($OriginalScripts{$app})) {
$OriginalScripts{$app} = "$dir/$script";
}
}
}
%RootScripts = ();
@scripts = get_files($pat, SCRIPTDIR);
foreach $script (@scripts) {
my $app = $script;
$app =~ s/$pat//;
$RootScripts{$app} = SCRIPTDIR ."/$script";
}
}
sub update_script {
my $app = shift;
my $suffix = (USERSPACE) ? "udefoma" : "defoma";
unless (copy($OriginalScripts{$app}, SCRIPTDIR . "/$app.$suffix")) {
printe("Failed to copy " . $OriginalScripts{$app} . "to " .
SCRIPTDIR . ".");
set_app_info($app, 'error', 1);
return 1;
}
mkdir(ROOTDIR . "/$app.d");
unless (-d ROOTDIR . "/$app.d") {
printe("Failed to create application directory: " . ROOTDIR . ".");
set_app_info($app, 'error', 1);
return 1;
}
return 0;
}
sub remove_script {
my $app = shift;
my $suffix = (USERSPACE) ? "udefoma" : "defoma";
unlink(SCRIPTDIR . "/$app.$suffix");
}
sub purge_script {
my $app = shift;
remove_script($app);
rrm("$app.d") if (compare_version_app($app, "0.10") >= 0);
links_purge($app);
clear_app_info($app);
}
sub load_scripts {
my $updateapp = shift || '';
foreach my $app (keys(%AppInfo)) {
if ($AppInfo{$app}->{script_change} eq 'new' && $app eq $updateapp) {
# new script
next if (update_script($app));
}
my $suffix = (USERSPACE) ? "udefoma" : "defoma";
my $script = SCRIPTDIR . "/$app.$suffix";
next unless (-f $script);
@ACCEPT_CATEGORIES = ();
undef $APPINFO;
$APPINFO = {};
eval('require($script);');
if ($@) {
printe("Unable to load: $script because:\n$@");
set_app_info($app, 'error', 1);
}
if (compare_version_app($app, VERSION) > 0) {
printe("$app.$suffix requires defoma ", $AppInfo{$app}->{require},
" or later version while the installed version is ",
VERSION, ".");
set_app_info($app, 'error', 1);
next;
}
if ($AppInfo{$app}->{script_change} eq 'new' && $app eq $updateapp &&
compare_version_app($app, "0.10") >= 0) {
# new script
subdirs_update($app) && next;
links_update($app) && next;
}
set_app_categories($app, @ACCEPT_CATEGORIES);
# set_app_info($app, 'info', $APPINFO);
}
}
sub init {
read_status_cache(ROOTDIR);
init_scripts();
diff_scripts();
}
sub init2 {
load_scripts(@_);
write_status_cache();
}
sub term {
my @list = keys(%Initialized);
my ($i, $c, $a);
foreach $i (@list) {
$i =~ /(.*)\/(.*)/;
$c = $1;
$a = $2;
push(@DefaultPackage, $DEFAULT_PACKAGE);
push(@DefaultCategory, $DEFAULT_CATEGORY);
$DEFAULT_PACKAGE = $a;
$DEFAULT_CATEGORY = $c;
$a =~ s/[^a-zA-Z0-9]/_/g;
$c =~ s/[^a-zA-Z0-9]/_/g;
eval("${a}::${c}('term')");
printw("In ${a}::${c}('term'): ", $@) if ($@);
$DEFAULT_PACKAGE = pop(@DefaultPackage);
$DEFAULT_CATEGORY = pop(@DefaultCategory);
}
write_status_cache();
foreach my $app (keys(%AppInfo)) {
if ($AppInfo{$app}->{error}) {
remove_script($app);
printe("$app was excluded from configuration due to the error " .
"in the header.");
printe("Please perform the following things.");
printe(" (1) run defoma-app purge $app.");
printe(" (2) upgrade $app and/or defoma.");
printe(" (3) run defoma-app update $app.");
}
}
return 0;
}
sub subdirs_update {
my $app = shift;
my $pkgdir = ROOTDIR . "/$app.d";
if ($APPINFO->{subdirs}) {
if ($AppInfo{$app}->{subdirs}) {
foreach my $dir (@{$AppInfo{$app}->{subdirs}}) {
unless (grep($_ eq $dir, @{$APPINFO->{subdirs}})) {
# obsoleted subdirectory
rrm("$app.d/$dir");
$dir = '';
}
}
}
foreach my $dir (@{$APPINFO->{subdirs}}) {
if ($dir =~ /^\// || $dir =~ /\.\./) {
printe("Illegal app subdirs: $pkgdir/$dir. ");
set_app_info($app, 'error', 1);
return 1;
}
unless (-d "$pkgdir/$dir") {
# new subdirectory
if (mkdirp("$pkgdir/$dir")) {
printe("$pkgdir/$dir: mkdir failed. ");
set_app_info($app, 'error', 1);
return 1;
}
push_app_info($app, 'subdirs', $dir);
}
}
} elsif ($AppInfo{$app}->{subdirs}) {
foreach my $dir (@{$AppInfo{$app}->{subdirs}}) {
# obsoleted subdirectory
rrm("$app.d/$dir");
$dir = '';
}
}
}
sub links_update {
my $app = shift;
my $pkgdir = ROOTDIR . "/$app.d";
if ($APPINFO->{links}) {
if ($AppInfo{$app}->{links}) {
foreach my $links (@{$AppInfo{$app}->{links}}) {
unless (grep($_ eq $links, @{$APPINFO->{links}})) {
# obsoleted link
my @l = split(' ', $links);
unlink(DEFOMA_TEST_DIR . $l[1]);
$links = '';
}
}
}
foreach my $links (@{$APPINFO->{links}}) {
next if ($AppInfo{$app}->{links} &&
grep($_ eq $links, @{$AppInfo{$app}->{links}}));
# new link
my @l = split(' ', $links);
unless (@l == 2) {
printe("$app contains illegal links in the header.");
next;
}
my $src = $l[0];
my $dest = DEFOMA_TEST_DIR . "$l[1]";
if ($dest !~ /^\// || index($dest, ROOTDIR) != -1 ||
$src =~ /^\// || $src =~ /\.\./) {
printe("Illegal app links: $dest -> $pkgdir/$src. ");
set_app_info($app, 'error', 1);
return 1;
}
unless (symlink("$pkgdir/$src", $dest)) {
printe("$dest -> $pkgdir/$src: symlink failed. ");
set_app_info($app, 'error', 1);
return 1;
}
push_app_info($app, 'links', $links);
}
} elsif ($AppInfo{$app}->{links}) {
links_purge($app);
}
}
sub links_purge {
my $app = shift;
if ($AppInfo{$app}->{links}) {
foreach my $links (@{$AppInfo{$app}->{links}}) {
my @l = split(' ', $links);
unlink(DEFOMA_TEST_DIR . $l[1]);
$links = '';
}
}
}
sub call_1 {
my $fobj = shift;
my $app = shift;
my $com = shift;
my $category = shift;
my $font = shift;
return 0 if ($AppInfo{$app}->{ignoreall});
return 0 if ($AppInfo{$app}->{ignore_category} &&
exists($AppInfo{$app}->{ignore_category}->{$category}));
push(@DefaultPackage, $DEFAULT_PACKAGE);
push(@DefaultCategory, $DEFAULT_CATEGORY);
$DEFAULT_PACKAGE = $app;
$DEFAULT_CATEGORY = $category;
my $appi = $app;
$appi =~ s/[^a-zA-Z0-9]/_/g;
my $ctgi = $category;
$ctgi =~ s/[^a-zA-Z0-9]/_/g;
unless (exists($Initialized{"$category/$app"})) {
$Initialized{"$category/$app"} = '';
eval("${appi}::${ctgi}('init')");
printw("In ${appi}::${ctgi}('init'): ", $@) if ($@);
}
my $ret = eval("${appi}::${ctgi}(\$com, \$font, \@_)");
printw("In ${appi}::${ctgi}('$com', '$font', ...): ", $@) if ($@);
$DEFAULT_PACKAGE = pop(@DefaultPackage);
$DEFAULT_CATEGORY = pop(@DefaultCategory);
if ($fobj && $com eq 'unregister') {
if ($fobj->remove_failed($font, $app)) {
return 0;
}
}
if ($ret && $fobj && $com eq 'register') {
$fobj->add_failed($font, $app, $ret);
printv("$font: failed to register for package $app, status($ret).");
}
return $ret;
}
sub call_m {
my $fobj = shift;
my $com = shift;
my $category = shift;
my $font = shift;
return unless (exists($Categories{$category}));
foreach my $app (@{$Categories{$category}}) {
call_1($fobj, $app, $com, $category, $font, @_);
}
return 0;
}
sub rrm {
my $dir = shift;
my $cwd = getcwd();
chdir(ROOTDIR);
return 1 unless (ROOTDIR eq getcwd());
return 1 if ($dir =~ /^\// || $dir =~ /\.\./);
system("/bin/rm", "-r", $dir) if (-e $dir);
chdir($cwd);
return 0;
}
sub mkdirp {
my $dir = shift;
my $dirs = '';
foreach my $d (split('/', $dir)) {
$dirs .= "/" . $d;
next if (-d $dirs);
mkdir($dirs) || return 1;
}
return 0;
}
sub compare_version {
my @v1 = split(/\./, shift);
my @v2 = split(/\./, shift);
while (@v1 > 0 || @v2 > 0) {
my $vv1 = (@v1 > 0) ? shift(@v1) : 0;
my $vv2 = (@v2 > 0) ? shift(@v2) : 0;
return -1 if ($vv1 < $vv2);
return 1 if ($vv1 > $vv2);
}
return 0;
}
sub compare_version_app {
my $app = shift;
my $v = ($AppInfo{$app} && $AppInfo{$app}->{require}) ?
$AppInfo{$app}->{require} : 0;
return compare_version($v, shift);
}
sub get_app_categories {
my $app = shift;
return () unless (exists($AppInfo{$app}) &&
exists($AppInfo{$app}->{category}));
return @{$AppInfo{$app}->{category}};
}
sub get_apps {
return keys(%AppInfo);
}
1;
Debian/Defoma/FontCache.pm 0000666 00000006406 15077711155 0011334 0 ustar 00 package Debian::Defoma::FontCache;
use strict;
use POSIX;
use FileHandle;
my $Rootdir = '';
sub initialize {
$Rootdir = shift;
}
sub new {
my $class = shift;
my $c;
my $o = {
category => shift,
updated => 0,
cache_list => {},
fcache_list => {},
ucache_list => {},
rootdir => shift
};
$o->{rootdir} = $Rootdir unless (defined($o->{rootdir}));
bless $o;
return $o;
}
sub read {
my $o = shift;
my $c = $o->{category};
my $rootdir = $o->{rootdir};
my $file = "$rootdir/$c.font-cache";
my $fh = new FileHandle($file, "r");
if (defined($fh)) {
while (<$fh>) {
chomp($_);
$_ =~ /^([^ ]+)[ ]+(.*)$/;
$o->{cache_list}->{$1} = $2;
}
$fh->close();
}
$file = "$rootdir/$c.failed-font-cache";
$fh = new FileHandle($file, "r");
if (defined($fh)) {
while (<$fh>) {
chomp($_);
$_ =~ /^([^ ]+) ([^ ]+) ([^ ]+)$/;
unless (exists($o->{fcache_list}->{$1})) {
$o->{fcache_list}->{$1} = {};
}
$o->{fcache_list}->{$1}->{$2} = $3;
}
$fh->close();
}
$file = "$rootdir/$c.user-font-cache";
$fh = new FileHandle($file, "r");
if (defined($fh)) {
while (<$fh>) {
chomp($_);
$o->{ucache_list}->{$_} = undef;
}
$fh->close();
}
return 0;
}
sub write {
my $o = shift;
my $c = $o->{category};
my $rootdir = $o->{rootdir};
my ($a, $max, $f);
my @fonts;
my $file = "$rootdir/$c.font-cache";
my $fh = new FileHandle($file, "w");
if (defined($fh)) {
@fonts = keys(%{$o->{cache_list}});
foreach $f (@fonts) {
$fh->print($f, ' ', $o->{cache_list}->{$f}, "\n");
}
$fh->close();
}
unlink($file) unless(-s $file);
$file = "$rootdir/$c.failed-font-cache";
$fh = new FileHandle($file, "w");
if (defined($fh)) {
@fonts = keys(%{$o->{fcache_list}});
foreach $f (@fonts) {
my @apps = keys(%{$o->{fcache_list}->{$f}});
foreach $a (@apps) {
$fh->print($f, ' ', $a, ' ', $o->{fcache_list}->{$f}->{$a},
"\n");
}
}
$fh->close();
}
unlink($file) unless(-s $file);
$file = "$rootdir/$c.user-font-cache";
$fh = new FileHandle($file, "w");
if (defined($fh)) {
@fonts = keys(%{$o->{ucache_list}});
foreach $f (@fonts) {
$fh->print($f, "\n");
}
$fh->close();
}
unlink($file) unless(-s $file);
return 0;
}
sub add_font {
my $o = shift;
my $font = shift;
my @hints = @_;
$o->{cache_list}->{$font} = join(' ', @hints);
$o->{updated} = 1;
return 0;
}
sub add_failed {
my $o = shift;
my $f = shift;
my $a = shift;
my $e = shift;
$o->{fcache_list}->{$f} = {} unless (exists($o->{fcache_list}->{$f}));
$o->{fcache_list}->{$f}->{$a} = $e;
return 0;
}
sub add_user {
my $o = shift;
my $f = shift;
$o->{ucache_list}->{$f} = undef;
}
sub remove_font {
my $o = shift;
my $f = shift;
delete($o->{cache_list}->{$f});
$o->{updated} = 1;
return 0;
}
sub remove_failed {
my $o = shift;
my $f = shift;
my $a = shift;
if (exists($o->{fcache_list}->{$f}->{$a})) {
delete($o->{fcache_list}->{$f}->{$a});
return 1;
}
return 0;
}
sub remove_user {
my $o = shift;
my $f = shift;
if (exists($o->{ucache_list}->{$f})) {
delete($o->{ucache_list}->{$f});
}
}
1;
Debian/Defoma/Subst.pm 0000666 00000027423 15077711155 0010604 0 ustar 00 package Debian::Defoma::Subst;;
use strict;
use POSIX;
use Exporter;
use Debian::Defoma::Common;
use Debian::Defoma::SubstCache;
use Debian::Defoma::Id;
import Debian::Defoma::Common qw(®ister_subst_object &get_subst_object
$DEFAULT_PACKAGE $DEFAULT_CATEGORY);
use vars qw(@EXPORT @ISA $DEFAULT_PACKAGE $DEFAULT_CATEGORY);
@ISA = qw(Exporter);
@EXPORT = qw(&defoma_subst_open &defoma_subst_close
&defoma_subst_register &defoma_subst_unregister
&defoma_subst_add_rule &defoma_subst_remove_rule
&defoma_subst_remove_rule_by_num &defoma_subst_newrule);
sub emes {
if ($DEFAULT_PACKAGE && $DEFAULT_CATEGORY) {
printw("Subst: $DEFAULT_PACKAGE/$DEFAULT_CATEGORY: ", @_);
} else {
printw("Subst: ", @_);
}
}
sub emesd {
if ($DEFAULT_PACKAGE && $DEFAULT_CATEGORY) {
printd("Subst: $DEFAULT_PACKAGE/$DEFAULT_CATEGORY: ", @_);
} else {
printd("Subst: ", @_);
}
}
sub generate_hash {
my @list = @_;
my $key = '';
my $hashptr = {};
my $flagptr = {};
my $flag;
for (my $i = 0; $i < @list; $i++) {
if ($list[$i] =~ /^--(.*)/) {
$key = $list[$i];
if ($key =~ /(.+),(.)/) {
$key = $1;
$flag = $2;
} else {
$flag = 1;
}
$flagptr->{$key} = $flag;
} elsif ($key ne '') {
add_hash_list($hashptr, $key, $list[$i]);
}
}
$hashptr->{flag} = $flagptr;
return $hashptr;
}
sub get_base_priority {
my $hints = shift;
my $rule = shift;
my $priority = 0;
my ($p, $pc);
my $matchflag;
my $i;
my $j;
my $k;
my $key;
my $max = 0;
my @rule_keys = keys(%{$rule});
my @hints_values;
my @rule_values;
for ($i = 0; $i < @rule_keys; $i++) {
$key = $rule_keys[$i];
next if ($key eq 'flag');
if (exists($hints->{$key})) {
@hints_values = split(' ', $hints->{$key});
} else {
@hints_values = ();
}
@rule_values = split(/ /, $rule->{$key});
$matchflag = 0;
$pc = $p = $rule->{flag}->{$key};
$p = 1 if ($pc =~ /[^123]/);
for ($j = 0; $j < @rule_values; $j++) {
$max += $p;
for ($k = 0; $k < @hints_values; $k++) {
if ($rule_values[$j] eq $hints_values[$k]) {
$priority += $p;
$matchflag++;
}
}
}
if ($matchflag == 0 && $pc eq '*') {
return -1;
}
}
return -1 if ($max == 0);
$priority = int($priority * 100 / $max);
return $priority;
}
sub ar_rule {
my $com = shift;
my $sobj = shift;
my $idx = shift;
my $ruleid = shift;
my $prule = shift;
my $rulename = $sobj->{rulename};
my $iobj = $sobj->{idobject};
my $threshold = $sobj->{threshold};
my ($i, $id, $font, $pri, $phints, $ctg, $p, $ret, $j);
my (@l, @list);
my @hints;
$iobj->{delay}++;
@list = keys(%{$sobj->{cache}});
foreach $i (@list) {
@l = split(/ /, $i);
$font = $l[0];
$id = $l[1];
$j = $sobj->{cache}->{$i};
$phints = $j->{hash};
$ctg = $j->{category};
$pri = $j->{priority};
unless ($phints) {
# @l = $iobj->grep('real', f0 => $id, f1 => $font);
# next unless(@l);
if (exists($iobj->{hash01}->{$id.' '.$font})) {
$l[0] = $iobj->{hash01}->{$id.' '.$font};
next unless ($iobj->{2}->[$l[0]] =~ /^Sr/);
} else {
next;
}
@hints = split(' ', $iobj->{7}->[$l[0]]);
$phints = generate_hash(@hints);
$j->{hash} = $phints;
$j->{category} = $ctg = $iobj->{4}->[$l[0]];
$j->{priority} = $pri = $iobj->{3}->[$l[0]] / 10;
}
$p = get_base_priority($phints, $prule);
next if ($p < 40);
next if ($com && $p < $threshold && $sobj->{rule_regnum}->[$idx]);
$p += $pri;
if ($com) {
$ret = defoma_id_register($iobj, type => 'subst', font => $font,
id => $ruleid, priority => $p,
category => $ctg, origin => $id);
$sobj->{rule_regnum}->[$idx]++ unless ($ret);
} else {
$ret = defoma_id_unregister($iobj, type => 'subst', font => $font,
id => $ruleid);
$sobj->{rule_regnum}->[$idx]-- unless ($ret);
}
}
$iobj->{delay}--;
defoma_id_update($iobj, $ruleid);
}
sub ar_font {
my $com = shift;
my $sobj = shift;
my $font = shift;
my $id = shift;
my $pri = shift(@_);
my $ctg = shift;
my $phints = shift;
my $rulename = $sobj->{rulename};
my $iobj = $sobj->{idobject};
my $threshold = $sobj->{threshold};
my @rule;
my ($i, $max, $j, $ruleid, $prule, $p, $ret);
$max = $sobj->{rule_cnt};
for ($i = 0; $i < $max; $i++) {
$j = $sobj->{rule}->[$i];
next if ($j eq '' || $j =~ /^\#/);
@rule = split(/[ \t]+/, $j);
$ruleid = shift(@rule);
$prule = $sobj->{rule_hash}->[$i];
unless ($prule) {
$prule = generate_hash(@rule);
$sobj->{rule_hash}->[$i] = $prule;
}
$p = get_base_priority($phints, $prule);
next if ($p < 40);
next if ($com && $p < $threshold && $sobj->{rule_regnum}->[$i]);
$p += $pri;
if ($com) {
$ret = defoma_id_register($iobj, type => 'subst', font => $font,
id => $ruleid, priority => $p,
category => $ctg, origin => $id);
$sobj->{rule_regnum}->[$i]++ unless ($ret);
} else {
$ret = defoma_id_unregister($iobj, type => 'subst', font => $font,
id => $ruleid);
$sobj->{rule_regnum}->[$i]-- unless ($ret);
}
# &Debian::Defoma::Configure::call_1(0, $sobj->{pkg}, $com, $ctg, $font,
# $ruleid, $p, $id, $rulename);
}
}
sub defoma_subst_open {
my %args = @_;
return -1 unless (exists($args{rulename}));
my $rulename = $args{rulename};
my $threshold = exists($args{threshold}) ? $args{threshold} : 30;
my $idobject = exists($args{idobject}) ? $args{idobject} : '';
my $pkg = '';
my $suffix = '';
if ($idobject) {
$pkg = $idobject->{pkg};
$suffix = $idobject->{suffix};
}
my $prv = $args{private};
my $private = '';
if ($prv) {
return -1 unless ($idobject);
$private = $pkg.'/';
}
my $o = get_subst_object($private . $rulename);
return $o if ($o);
my $rulefile;
my $cachefile;
if ($prv) {
my $dir = ROOTDIR . '/' . $pkg . '.d/';
$rulefile = $dir . $rulename . '.private-subst-rule';
$cachefile = $dir . $rulename . '.private-subst-cache';
} else {
$rulefile = SUBSTRULEDIR . '/' . $rulename . '.subst-rule';
$cachefile = ROOTDIR . '/' . $rulename . '.subst-cache';
}
$o = new Debian::Defoma::SubstCache($rulename, $cachefile, $rulefile,
$pkg, $suffix, $idobject);
$o->{threshold} = $threshold;
$o->read();
if (! $idobject && $o->{pkg}) {
$idobject = $o->{idobject} = defoma_id_open_cache($o->{idsuffix},
$o->{pkg});
}
if ($idobject) {
my $max = $o->{rule_cnt};
my ($i, $j);
for ($i = 0; $i < $max; $i++) {
$j = $o->{rule}->[$i];
next if ($j eq '' || $j =~ /^\#/);
$j =~ /^([^ \t]+) /;
my $ruleid = $1;
$o->{rule_regnum}->[$i] = $idobject->grep('subst', f0 => $ruleid);
}
}
register_subst_object($o, $private . $rulename);
return $o;
}
sub defoma_subst_close {
my $o = shift;
if ($o) {
$o->write();
}
}
sub defoma_subst_register {
return -1 if (@_ < 3);
my $sobj = shift;
my $font = shift;
my $id = shift;
my $iobj = $sobj->{idobject};
my @l;
unless ($iobj) {
emes("IdObject is not set in SubstObject.");
return -1;
}
if (exists($sobj->{cache}->{$font.' '.$id})) {
emesd("$font, $id: already registered in subst-cache.");
return -1;
}
# @l = $iobj->grep('real', f0 => $id, f1 => $font);
# unless (@l) {
unless (exists($iobj->{hash01}->{$id.' '.$font})) {
emesd("$font, $id: not registered in id-cache.");
return -1;
}
$l[0] = $iobj->{hash01}->{$id.' '.$font};
unless ($iobj->{2}->[$l[0]] =~ /^Sr/) {
emesd("$font, $id: not registered in id-cache.");
return -1;
}
my @hints = split(' ', $iobj->{7}->[$l[0]]);
my $hash = generate_hash(@hints);
my $pri = $iobj->{3}->[$l[0]] / 10;
my $ctg = $iobj->{4}->[$l[0]];
$sobj->add_cache($font, $id, $hash, $pri, $ctg);
ar_font(1, $sobj, $font, $id, $pri, $ctg, $hash);
return 0;
}
sub defoma_subst_unregister {
return -1 if (@_ < 2);
my $sobj = shift;
my $font = shift;
my $id = shift;
my $iobj = $sobj->{idobject};
my ($hash, $pri, $ctg);
my (@hints, @l);
unless ($iobj) {
emes("$sobj->{rulename}: IdObject is not set in SubstObject.");
return -1;
}
my @ids = ();
if ($id) {
if (exists($sobj->{cache}->{$font.' '.$id})) {
push(@ids, $id);
} else {
emesd("$font, $id: not registered in subst-cache.");
return -1;
}
} else {
@l = keys(%{$sobj->{cache}});
foreach $id (@l) {
$id =~ /^([^ ]+) ([^ ]+)$/;
push(@ids, $2) if ($1 eq $font);
}
}
foreach $id (@ids) {
my $p = $sobj->{cache}->{$font.' '.$id};
$hash = $p->{hash};
$ctg = $p->{category};
$pri = $p->{priority};
unless ($hash) {
# @l = $iobj->grep('real', f0 => $id, f1 => $font);
if (exists($iobj->{hash01}->{$id.' '.$font})) {
$l[0] = $iobj->{hash01}->{$id.' '.$font};
next unless ($iobj->{2}->[$l[0]] =~ /^Sr/);
} else {
next;
}
@hints = split(' ', $iobj->{7}->[$l[0]]);
$hash = generate_hash(@hints);
$pri = $iobj->{3}->[$l[0]];
}
ar_font(0, $sobj, $font, $id, $pri, $ctg, $hash);
delete($sobj->{cache}->{$font.' '.$id});
}
return 0;
}
sub defoma_subst_add_rule {
my $sobj = shift;
my $rule = join(' ', @_);
my $idx;
if ($sobj->grep_rule($rule)) {
emesd("$sobj->{rulename}: Specified rule already exists.");
return -1;
}
my $ruleid = shift;
my $hash = generate_hash(@_);
$idx = $sobj->add_rule($rule, $hash);
unless ($sobj->{idobject}) {
emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
return -1;
}
ar_rule(1, $sobj, $idx, $ruleid, $hash);
return 0;
}
sub defoma_subst_remove_rule_by_num {
my $sobj = shift;
my $i = shift;
my @rule = split(' ', $sobj->{rule}->[$i]);
my $ruleid = shift(@rule);
my $hash = $sobj->{rule_hash}->[$i];
unless ($hash) {
$hash = generate_hash(@rule);
}
$sobj->delete_rule($i);
unless ($sobj->{idobject}) {
emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
next;
}
ar_rule(0, $sobj, $i, $ruleid, $hash);
}
sub defoma_subst_remove_rule {
my $sobj = shift;
my ($rule, $ruleid);
my @l;
return -1 if (@_ == 0);
if (@_ == 1) {
$ruleid = shift;
@l = $sobj->grep_rule('', $ruleid);
} else {
$ruleid = shift;
$rule = join(' ', $ruleid, @_);
@l = $sobj->grep_rule($rule);
}
my @r;
foreach my $i (@l) {
my $hash = $sobj->{rule_hash}->[$i];
unless ($hash) {
@r = split(' ', $sobj->{rule}->[$i]);
shift(@r);
$hash = generate_hash(@r);
}
$sobj->delete_rule($i);
unless ($sobj->{idobject}) {
emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
next;
}
ar_rule(0, $sobj, $i, $ruleid, $hash);
}
return 0;
}
sub defoma_subst_newrule {
my $file = shift;
my $rulename = shift;
if (open(F, '>' . $file)) {
my $text = <[,Score] .. --[,Score] ..
# HintType specifies the type of hint, like Family, Weight and Charset.
# Score specifies the degree of importance of the HintType and is either of
# 1, 2, 3 or *. The larger number, the more important. '*' means the
# specified HintType is required to match.
#
# Each item in a line is separated by space.
# Lines starting with '#' are ignored.
#
EOF
;
print F $text;
foreach my $i (@_) {
print F $i, "\n";
}
close F;
}
}
1;
Debian/Defoma/User.pm 0000666 00000004672 15077711155 0010423 0 ustar 00 package Debian::Defoma::User;
use strict;
use POSIX;
use Exporter;
use vars qw(@EXPORT @EXPORT_OK @ISA);
use Debian::Defoma::Font;
use Debian::Defoma::Common;
import Debian::Defoma::Common qw(&readfile &writefile);
@ISA = qw(Exporter);
@EXPORT = qw(&defoma_user_update_dotfile);
@EXPORT_OK = qw(&defoma_user_init &defoma_user_update_font);
my %SystemFontUpdateTime;
my $SystemUpdateTime;
my $SystemRoot = DEFOMA_TEST_DIR . "/var/lib/defoma";
sub defoma_user_init {
&Debian::Defoma::Configure::read_status_cache($SystemRoot);
&Debian::Defoma::Configure::get_status(\%SystemFontUpdateTime,
\$SystemUpdateTime);
&Debian::Defoma::Configure::clear_app_info();
}
sub defoma_user_update_font {
my %UserFontUpdateTime;
my $UserUpdateTime;
&Debian::Defoma::Configure::get_status(\%UserFontUpdateTime,
\$UserUpdateTime);
my @cs = ();
foreach my $c (keys(%SystemFontUpdateTime)) {
unless (defined($UserFontUpdateTime{$c}) &&
$UserFontUpdateTime{$c} >= $SystemFontUpdateTime{$c}) {
push(@cs, $c);
}
}
if (@cs) {
printm("Following font categories are updated in system: @cs");
printm("Updating ", USERLOGIN, "'s font caches...");
foreach my $c (@cs) {
printm(" Updating category $c..");
my $sfobj = new Debian::Defoma::FontCache($c, $SystemRoot);
$sfobj->read();
my $ufobj = defoma_font_get_object($c);
$ufobj->{updated} = 1;
foreach my $f (keys(%{$ufobj->{cache_list}})) {
if (! exists($sfobj->{cache_list}->{$f}) &&
! exists($ufobj->{ucache_list}->{$f})) {
defoma_font_unregister($c, $f);
}
}
foreach my $f (keys(%{$sfobj->{cache_list}})) {
if (! exists($ufobj->{ucache_list}->{$f})) {
my @hints = split(' ', $sfobj->{cache_list}->{$f});
$Debian::Defoma::Font::Userspace = 0;
defoma_font_reregister($c, $f, @hints);
}
}
}
} else {
printm("All font categories are configured up-to-date for ",
USERLOGIN, ".");
}
}
sub defoma_user_update_dotfile {
my $filename = shift;
my $begin = shift;
my $end = shift;
my @r = readfile(HOMEDIR . "/$filename");
my @w = ();
my $flag = 0;
foreach my $l (@r) {
if (defined($begin) && $begin ne '' && $begin eq $l) {
$flag = 1;
} elsif (defined($end) && $end ne '' && $end eq $l) {
$flag = 0;
} elsif ($flag == 0) {
push(@w, $l);
}
}
push(@w, $begin, @_, $end);
writefile(HOMEDIR . "/$filename", @w);
}
1;
Debian/Defoma/SubstCache.pm 0000666 00000005771 15077711155 0011532 0 ustar 00 package Debian::Defoma::SubstCache;;
use strict;
use POSIX;
use FileHandle;
sub new {
my $class = shift;
my $o = {
rulename => shift,
cachefile => shift,
rulefile => shift,
pkg => shift,
idsuffix => shift,
idobject => shift,
threshold => 30,
cache => {},
rule_cnt => 0,
rule => [],
rule_hash => [],
rule_regnum => []
};
bless $o;
return $o;
}
sub read {
my $o = shift;
my $i = -1;
my $fh = new FileHandle($o->{cachefile}, "r");
if (defined($fh)) {
while (<$fh>) {
chomp($_);
my @list = split(/ /, $_);
if ($i == -1) {
$o->{pkg} = shift(@list);
$o->{idsuffix} = (@list > 0) ? shift(@list) : '';
$o->{threshold} = shift(@list) if (@list > 0);
} else {
shift(@list) if (@list > 2);
$o->{cache}->{$list[0].' '.$list[1]} = {};
}
$i++;
}
$fh->close();
}
$i = 0;
$fh = new FileHandle($o->{rulefile}, "r");
if (defined($fh)) {
while (<$fh>) {
chomp($_);
if ($o->{rule}->[$i]) {
$o->{rule}->[$i] .= $_;
} else {
$o->{rule}->[$i] = $_;
}
if ($_ =~ /\\$/) {
$o->{rule}->[$i] =~ s/\\$/ /;
} else {
$i++;
}
}
$fh->close();
$i++ if ($o->{rule}->[$i]);
$o->{rule_cnt} = $i;
}
return 0;
}
sub write {
my $o = shift;
my ($i, $j, $max);
my $pkg = $o->{pkg};
my $suffix = $o->{idsuffix};
my $threshold = $o->{threshold};
my @list;
if ($pkg) {
my $fh = new FileHandle($o->{cachefile}, "w");
if (defined($fh)) {
$fh->print($pkg, ' ', $suffix, ' ', $threshold, "\n");
@list = keys(%{$o->{cache}});
foreach $i (@list) {
$fh->print($i, "\n");
}
$fh->close();
}
}
unlink($o->{cachefile}) unless (-s $o->{cachefile} && @list > 0);
my $fh = new FileHandle($o->{rulefile}, "w");
if (defined($fh)) {
$max = $o->{rule_cnt};
for ($i = 0; $i < $max; $i++) {
$j = $o->{rule}->[$i];
if ($j ne '') {
$fh->print($j, "\n");
}
}
$fh->close();
}
unlink($o->{rulefile}) unless(-s $o->{rulefile});
return 0;
}
sub grep_rule {
my $o = shift;
my $rule = shift;
my $ruleid = shift;
my @ret = ();
my ($i, $j, $max);
$max = $o->{rule_cnt};
for ($i = 0; $i < $max; $i++) {
$j = $o->{rule}->[$i];
next if ($j =~ /^\#/ || $j eq '');
if ($rule) {
if ($rule eq $j) {
push(@ret, $i);
}
} else {
$j =~ s/ .*$//;
if ($ruleid eq $j) {
push(@ret, $i);
}
}
}
return @ret;
}
sub add_cache {
my $o = shift;
my $font = shift;
my $id = shift;
my $p;
$o->{cache}->{$font.' '.$id} = $p = {};
$p->{hash} = shift;
$p->{priority} = shift;
$p->{category} = shift;
}
sub add_rule {
my $o = shift;
my $rule = shift;
my $rulehash = shift;
my $i = $o->{rule_cnt};
$o->{rule}->[$i] = $rule;
$o->{rule_hash}->[$i] = $rulehash;
$o->{rule_cnt}++;
return $i;
}
sub delete_rule {
my $o = shift;
foreach my $i (@_) {
$o->{rule}->[$i] = '';
$o->{rule_hash}->[$i] = '';
}
}
1;
Debian/Defoma/Id.pm 0000666 00000034756 15077711155 0010047 0 ustar 00 package Debian::Defoma::Id;
use strict;
use POSIX;
use Exporter;
use vars qw(@EXPORT @EXPORT_OK @ISA $DEFAULT_PACKAGE $DEFAULT_CATEGORY
$Purge $IDOBJECT);
use Debian::Defoma::Common;
use Debian::Defoma::IdCache;
import Debian::Defoma::Common qw(®ister_id_object &get_id_object
&arg_check
$DEFAULT_PACKAGE $DEFAULT_CATEGORY);
@ISA = qw(Exporter);
@EXPORT = qw(&defoma_id_register &defoma_id_unregister
&defoma_id_open_cache &defoma_id_close_cache
&defoma_id_get_font &defoma_id_grep_cache
&defoma_id_set &defoma_id_unset
&defoma_id_update &defoma_id_get_hints);
@EXPORT_OK = qw($IDOBJECT);
my %TYPE = ('r' => 'real', 'a' => 'alias', 'S' => 'subst');
my %RTYPE = ('real' => 'Sr', 'alias' => 'Sa', 'subst' => 'SS',
'useralias' => 'Ua');
$Purge = 0;
undef $IDOBJECT;
sub emes {
my $o = shift;
my $pkg = $o->{pkg} || $DEFAULT_PACKAGE || 'Unknown';
printw("Id: $pkg: ", @_);
}
sub emesd {
my $o = shift;
my $pkg = $o->{pkg} || $DEFAULT_PACKAGE || 'Unknown';
printd("Id: $pkg: ", @_);
}
my $Obj;
sub sorter {
my $a1 = $Obj->{2}->[$a];
$a1 =~ s/^(..)(.*)/$1/;
my $a2 = $2;
my $a3 = $Obj->{3}->[$a];
my $b1 = $Obj->{2}->[$b];
$b1 =~ s/^(..)(.*)/$1/;
my $b2 = $2;
my $b3 = $Obj->{3}->[$b];
($b1 ne $a1) && return ($b1 cmp $a1);
($b3 != $a3) && return ($b3 <=> $a3);
return -1 if ($a2);
return 1 if ($b2);
return 0;
}
sub check_if_installed {
my $obj = shift;
my $id = shift;
my $font = shift;
my @ret = ();
if ($id ne '.' && $font ne '.') {
if (exists($obj->{hash01}->{$id.' '.$font})) {
my $i = $obj->{hash01}->{$id.' '.$font};
return ($obj->{2}->[$i] =~ /I$/);
} else {
return 0;
}
# return $obj->grep('installed', f0 => $id, f1 => $font);
} elsif ($id ne '.' && $font eq '.') {
# return $obj->grep('installed', f0 => $id);
return exists($obj->{hash0_installed}->{$id});
} elsif ($id eq '.' && $font ne '.') {
return $obj->grep('installed', f1 => $font);
}
return @ret;
}
sub get_top_prior {
my $obj = shift;
my $id = shift;
my @index;
my %exclude = ();
my $i;
my $j;
my @list;
# Check marked fonts providing the id first.
@index = $obj->grep('mark', f0 => $id);
@index = sort (@index);
foreach $i (@index) {
# If a certain font is marked as 'install'...
if ($obj->{2}->[$i] eq 'Mu') {
# Check if the font is actually registered,
# @list = $obj->grep('font', f1 => $obj->{1}->[$i],
# f0 => $obj->{0}->[$i]);
# if (@list) {
# $j = $list[0];
if (exists($obj->{hash01}->{$obj->{0}->[$i].' '.$obj->{1}->[$i]})){
# In case the font is registered:
$j = $obj->{hash01}->{$obj->{0}->[$i].' '.$obj->{1}->[$i]};
if ($obj->{5}->[$j] ne '.' || $obj->{6}->[$j] ne '.') {
# If the font depends on another font, and that font
# is not actually installed, ignore the 'install' flag.
next unless (check_if_installed($obj, $obj->{5}->[$j],
$obj->{6}->[$j]));
}
return $j;
}
} elsif ($obj->{2}->[$i] eq 'Mx' or $obj->{2}->[$i] eq 'MX') {
# If a certain font is marked as 'exclude'...
$exclude{$obj->{1}->[$i]} = 1;
}
}
# Check all fonts providing the id.
@index = $obj->grep('font', f0 => $id);
$Obj = $obj;
@index = sort sorter (@index);
foreach $i (@index) {
next if (exists($exclude{$obj->{1}->[$i]}));
next if (exists($obj->{unregistering}->{$i}));
my $did = $obj->{5}->[$i];
my $dfont = $obj->{6}->[$i];
if ($did ne '.' || $dfont ne '.') {
# If the font depends on another font, and that font is not
# actually installed, ignore it.
next unless (check_if_installed($obj, $did, $dfont));
}
return $i;
}
return -1;
}
sub call_do_remove {
my $obj = shift;
my $i = shift;
my $id = $obj->{0}->[$i];
$obj->{2}->[$i] =~ /^.(.)I$/;
my $typestr = $TYPE{$1};
my $depid = ($obj->{5}->[$i] eq '.') ? '' : $obj->{5}->[$i];
my $depfont = ($obj->{6}->[$i] eq '.') ? '' : $obj->{6}->[$i];
my @hints = defoma_id_get_hints($obj, $i);
$IDOBJECT = $obj;
&Debian::Defoma::Configure::call_1(0, $obj->{pkg},
"do-remove-$typestr", $obj->{4}->[$i],
$obj->{1}->[$i], $id, $depfont, $depid,
@hints) if ($obj->{callback});
$obj->uninstall($i);
do_update_depend(0, $obj, $id, $obj->{1}->[$i]);
}
sub call_do_install {
my $obj = shift;
my $i = shift;
my $id = $obj->{0}->[$i];
$obj->{2}->[$i] =~ /^.(.)$/;
my $typestr = $TYPE{$1};
my $depid = ($obj->{5}->[$i] eq '.') ? '' : $obj->{5}->[$i];
my $depfont = ($obj->{6}->[$i] eq '.') ? '' : $obj->{6}->[$i];
my @hints = defoma_id_get_hints($obj, $i);
my $font = $obj->{1}->[$i];
my $ctg = $obj->{4}->[$i];
$obj->install($i);
$IDOBJECT = $obj;
my $ret = 0;
$ret = &Debian::Defoma::Configure::call_1(0, $obj->{pkg},
"do-install-$typestr", $ctg,
$font, $id, $depfont, $depid,
@hints) if ($obj->{callback});
if ($ret) {
$obj->uninstall($i);
do_set($obj, $id, $font, 'error');
my $text = <{pkg}
Category\: $ctg
Installing Font\: $font
Installing ID\: $id
Defoma has set this font as \'exclude\' to keep it from being installed.
You can still have it installed by unsetting the \'exclude\' mark after the cause of the error gets removed.
EOF
;
printw($text) if ($ret == 1);
do_update($obj, $id);
} else {
do_update_depend(1, $obj, $id, $font);
}
}
sub do_update {
my $obj = shift;
my $id = shift;
my $i1 = -1;
my $i2 = -1;
my $font1 = '';
my $font2 = '';
my @list;
# @list = $obj->grep('installed', f0 => $id);
# if (@list > 0) {
# $i1 = $list[0];
if (exists($obj->{hash0_installed}->{$id})) {
$i1 = $obj->{hash0_installed}->{$id};
$font1 = $obj->{1}->[$i1];
}
$i2 = get_top_prior($obj, $id);
if ($i2 >= 0) {
$font2 = $obj->{1}->[$i2];
}
return if ($font1 eq $font2);
if ($i1 >= 0) {
call_do_remove($obj, $i1);
}
return if ($obj->{delay});
if ($i2 >= 0) {
call_do_install($obj, $i2);
}
}
sub do_update_depend {
my $com = shift;
my $obj = shift;
my $id = shift;
my $font = shift;
my @l;
my %list;
if (exists($obj->{hash5}->{$id})) {
@l = keys(%{$obj->{hash5}->{$id}});
grep($list{$_} = undef, @l);
}
if (exists($obj->{hash6}->{$font})) {
@l = keys(%{$obj->{hash6}->{$font}});
grep($list{$_} = undef, @l);
}
foreach my $i (keys(%list)) {
next if ($obj->{5}->[$i] ne '.' && $obj->{5}->[$i] ne $id);
next if ($obj->{6}->[$i] ne '.' && $obj->{6}->[$i] ne $font);
next if ($com == 0 && $obj->{2}->[$i] !~ /I$/);
next if ($com == 1 && $obj->{2}->[$i] =~ /I$/);
do_update($obj, $obj->{0}->[$i]);
}
}
sub do_unset {
my $obj = shift;
my $id = shift;
my $font = shift;
# my @list = $obj->grep('mark', f0 => $id, f1 => $font, r2 => '^M[ux]');
# if (@list > 0) {
# $obj->delete(@list);
if (exists($obj->{hash01_mark}->{$id.' '.$font})) {
$obj->delete($obj->{hash01_mark}->{$id.' '.$font});
}
}
sub do_set {
my $obj = shift;
my $id = shift;
my $font = shift;
my $type = shift;
my $typestr;
if ($type eq 'install') {
$typestr = 'Mu';
} elsif ($type eq 'exclude') {
$typestr = 'MX';
} elsif ($type eq 'error') {
$typestr = 'Mx';
}
if ($type eq 'install') {
my @list = $obj->grep('mark', f0 => $id, f2 => 'Mu');
if (@list > 0) {
$obj->delete($list[0]);
}
}
if (exists($obj->{hash01_mark}->{$id . ' '. $font})) {
$obj->delete($obj->{hash01_mark}->{$id . ' '. $font});
}
return $obj->add($id, $font, $typestr, '-', '-', '-', '-', '-');
}
sub defoma_id_open_cache {
my $suffix = (@_ > 0) ? shift(@_) : '';
my $pkg = (@_ > 0) ? shift(@_) : $DEFAULT_PACKAGE;
my $o;
$suffix =~ s/[^a-zA-Z0-9_-]/_/g;
$o = get_id_object($pkg, $suffix);
return $o if ($o);
my $file = ROOTDIR . '/' . $pkg . '.d/id-cache';
$file .= '.' . $suffix if ($suffix);
$o = new Debian::Defoma::IdCache($file, $pkg, $suffix);
$o->read();
register_id_object($o, $pkg, $suffix);
return $o;
}
sub defoma_id_close_cache {
my $o = shift;
if ($o) {
$o->write();
}
}
sub defoma_id_register {
my $obj = shift;
my %args = @_;
unless (exists($args{type}) && exists($args{font}) && exists($args{id}) &&
exists($args{priority})) {
emes($obj, "register: Required argument is missing.");
return -1;
}
my $comtype = $args{type};
my $font = $args{font};
my $id = $args{id};
my $priority = $args{priority};
if ($comtype !~ /^(real|alias|useralias|subst)$/) {
emes($obj, "Unknown type '$comtype'.");
return -1;
}
my $type = $RTYPE{$comtype};
arg_check($id, $font, $priority) || return -1;
return -1 if ($priority =~ /[^0-9]/);
$priority = 999 if ($priority >= 1000);
$priority = 0 if ($priority < 0);
my $category = $DEFAULT_CATEGORY;
my $depfont = '.';
my $depid = '.';
my $hints = '';
my $i;
my $dependflag = 0;
my @l;
$category = $args{category} if (exists($args{category}));
if (exists($args{depend})) {
@l = split(/ /, $args{depend});
if (@l == 2) {
$depfont = $l[0];
$depid = $l[1];
}
}
if (exists($args{origin})) {
$depfont = $font;
$depid = $args{origin};
}
if (exists($args{hints})) {
if ($type eq 'Sr') {
$hints = $args{hints};
} else {
emesd($obj, "register: Only type => 'real' accepts 'hints'.");
}
}
if ($type ne 'Sr' && ($depid eq '.' || $depfont eq '.')) {
emes($obj, "'$comtype' requires 'origin' be specified.");
return -1;
}
# if ($obj->grep('font', f0 => $id, f1 => $font)) {
if (exists($obj->{hash01}->{$id.' '.$font})) {
emesd($obj, "$id: already registered by $font.");
return -1;
}
$obj->add($id, $font, $type, $priority, $category, $depid, $depfont,
$hints);
do_update($obj, $id);
return 0;
}
sub defoma_id_unregister {
my $obj = shift;
my %args = @_;
unless (exists($args{type}) && exists($args{font})) {
emes($obj, "register: Required argument is missing.");
return -1;
}
my $comtype = $args{type};
my $font = $args{font};
my $id = (exists($args{id})) ? $args{id} : '';
if ($comtype !~ /^(real|alias|subst)$/) {
emes($obj, "Unknown type '$comtype'.");
return -1;
}
my @index;
my ($i, $m);
my $j = -1;
if ($id eq '') {
@index = $obj->grep($comtype, f1 => $font);
} else {
# @index = $obj->grep($comtype, f0 => $id, f1 => $font);
if (exists($obj->{hash01}->{$id.' '.$font})) {
$j = $obj->{hash01}->{$id.' '.$font};
$index[0] = $j if ($obj->{2}->[$j] =~ /^$RTYPE{$comtype}/);
}
}
return -1 unless(@index);
foreach $i (@index) {
next if ($obj->{2}->[$i] =~ /^Ua/ && $Purge == 0);
$id = $obj->{0}->[$i];
$obj->{unregistering}->{$i} = '';
do_update($obj, $id);
# do_unset($obj, $id, $font) if ($Purge);
$obj->delete($i);
delete($obj->{unregistering}->{$i});
if (exists($obj->{hash01_mark}->{$id.' '.$font})) {
$j = $obj->{hash01_mark}->{$id.' '.$font};
$obj->delete($j) if ($obj->{2}->[$j] eq 'Mx' || $Purge);
}
# my @l = $obj->grep('mark', f0 => $id, f1 => $font);
# if (@l) {
# $obj->delete(@l);
# }
}
}
sub sort_result {
$Obj = shift;
my $sorttype = shift;
my $sortkey = shift;
if ($sorttype eq 'p') {
return sort sorter (@_);
} elsif ($sorttype eq 'n') {
return sort { $Obj->{$sortkey}->[$a] <=> $Obj->{$sortkey}->[$b] } (@_);
} elsif ($sorttype eq 'a') {
return sort { $Obj->{$sortkey}->[$a] cmp $Obj->{$sortkey}->[$b] } (@_);
}
}
my %Conv = ( id => 'f0', font => 'f1', type => 'f2', priority => 'f3',
category => 'f4', depid => 'f5', depfont => 'f6', hints => 'f7');
sub convert_grep_argument {
my @ret = ();
while (@_ > 0) {
my $key = shift;
my $value = shift;
if (exists($Conv{$key})) {
push(@ret, $Conv{$key}, $value);
} else {
push(@ret, $key, $value);
}
}
return @ret;
}
sub defoma_id_grep_cache {
my $o = shift;
my $t = shift;
my %args = convert_grep_argument(@_);
my @ret = ();
my $sorttype = '';
my $sortkey;
if (exists($args{sortkey})) {
$sortkey = $args{sortkey};
if (exists($Conv{$sortkey})) {
$Conv{$sortkey} =~ /^(.)(.)/;
$sortkey = $2;
} else {
undef $sortkey;
}
delete $args{sortkey};
}
if (exists($args{sorttype})) {
$sorttype = $args{sorttype};
undef $sorttype if ($sorttype !~ /^[nap]$/);
undef $sorttype if ($sorttype =~ /^[na]$/ && ! defined($sortkey));
delete $args{sorttype};
}
if (exists($args{f0}) && exists($args{f1})) {
if ($t eq 'mark') {
if (exists($o->{hash01_mark}->{$args{f0}.' '.$args{f1}})) {
push(@ret, $o->{hash01_mark}->{$args{f0}.' '.$args{f1}});
}
} else {
if (exists($o->{hash01}->{$args{f0}.' '.$args{f1}})) {
push(@ret, $o->{hash01}->{$args{f0}.' '.$args{f1}});
}
}
@ret = sort_result($o, $sorttype, $sortkey, @ret) if ($sorttype);
return @ret;
}
if (exists($args{f0}) && $t eq 'installed') {
if (exists($o->{hash0_installed}->{$args{f0}})) {
push(@ret, $o->{hash0_installed}->{$args{f0}});
}
@ret = sort_result($o, $sorttype, $sortkey, @ret) if ($sorttype);
return @ret;
}
@ret = $o->grep($t, %args);
@ret = sort_result($o, $sorttype, $sortkey, @ret) if ($sorttype);
return @ret;
}
sub defoma_id_get_font {
return defoma_id_grep_cache(@_);
}
sub defoma_id_update {
my $o = shift;
my $id = shift;
do_update($o, $id);
}
sub defoma_id_get_hints {
my $obj = shift;
my $i = shift;
my $type = $obj->{2}->[$i];
my $id;
my $font;
my $h;
if ($type =~ /^Sr/) {
return split(' ', $obj->{7}->[$i]);
} else {
$id = $obj->{5}->[$i];
$font = $obj->{6}->[$i];
if (exists($obj->{hash01}->{$id.' '.$font})) {
my $j = $obj->{hash01}->{$id.' '.$font};
return split (' ', $obj->{7}->[$j]);
} else {
return undef;
}
}
# my @list = $obj->grep('real', f0 => $id, f1 => $font);
# if (@list > 0) {
# return $obj->{7}->[$list[0]];
# } else {
# return '';
# }
}
sub defoma_id_set {
my $obj = shift;
my $id = shift;
my $font = shift;
my $mark = shift;
do_set($obj, $id, $font, $mark);
do_update($obj, $id);
}
sub defoma_id_unset {
my $obj = shift;
my $id = shift;
my $font = shift;
do_unset($obj, $id, $font);
do_update($obj, $id);
}
1;
Debian/Dselect/Ftp.pm 0000666 00000021327 15077711155 0010422 0 ustar 00 # -*-perl-*-
use Net::FTP;
use Exporter;
use Data::Dumper;
use strict;
use vars qw(@EXPORT %config $VAR1);
@EXPORT = qw(yesno do_connect do_mdtm add_site edit_site
edit_config read_config store_config view_mirrors nb);
sub nb {
my $nb = shift;
if ($nb > 1024**2) {
return sprintf("%.2fM", $nb / 1024**2);
} elsif ($nb > 1024) {
return sprintf("%.2fk", $nb / 1024);
} else {
return sprintf("%.2fb", $nb);
}
}
sub read_config {
my $vars = shift;
my ($code, $conf);
local($/);
open(VARS, $vars) || die "Couldn't open $vars : $!\nTry to relaunch the 'Access' step in dselect, thanks.\n";
$code = ;
close VARS;
$conf = eval $code;
die "Couldn't eval $vars content : $@\n" if ($@);
if (ref($conf) =~ /HASH/) {
foreach (keys %{$conf}) {
$config{$_} = $conf->{$_};
}
} else {
print "Bad $vars file : removing it.\n";
print "Please relaunch the 'Access' step in dselect. Thanks.\n";
unlink $vars;
exit 0;
}
}
sub store_config {
my $vars = shift;
# Check that config is completed
return if not $config{'done'};
open(VARS, ">$vars") || die "Couldn't open $vars in write mode : $!\n";
print VARS Dumper(\%config);
close VARS;
}
sub view_mirrors {
if (-f '/usr/lib/dpkg/methods/ftp/README.mirrors.txt') {
system('/usr/bin/pager', '/usr/lib/dpkg/methods/ftp/README.mirrors.txt');
} elsif (-f '/usr/lib/dpkg/methods/ftp/README.mirrors.txt.gz') {
system('gzip -dc /usr/lib/dpkg/methods/ftp/README.mirrors.txt.gz | pager');
} else {
print "/usr/lib/dpkg/methods/ftp/README.mirrors.txt(.gz): file not found.\n";
}
}
sub edit_config {
my $methdir = shift;
my $i;
#Get a config for ftp sites
while(1) {
$i = 1;
print "\n\nList of selected ftp sites :\n";
foreach (@{$config{'site'}}) {
print "$i. ftp://$_->[0]$_->[1] @{$_->[2]}\n";
$i++;
}
print "\nEnter a command (a=add e=edit d=delete q=quit m=mirror list) \n";
print "eventually followed by a site number : ";
chomp($_ = );
/q/i && last;
/a/i && add_site();
/d\s*(\d+)/i &&
do { splice(@{$config{'site'}}, $1-1, 1) if ($1 <= @{$config{'site'}});
next;};
/e\s*(\d+)/i &&
do { edit_site($config{'site'}[$1-1]) if ($1 <= @{$config{'site'}});
next; };
m#m#i && view_mirrors();
}
print "\n";
$config{'use_auth_proxy'} = yesno($config{'use_auth_proxy'} ? "y" : "n",
"Go through an authenticated proxy");
if ($config{'use_auth_proxy'}) {
print "\nEnter proxy hostname [$config{'proxyhost'}] : ";
chomp($_ = );
$config{'proxyhost'} = $_ || $config{'proxyhost'};
print "\nEnter proxy log name [$config{'proxylogname'}] : ";
chomp($_ = );
$config{'proxylogname'} = $_ || $config{'proxylogname'};
print "\nEnter proxy password [$config{'proxypassword'}] : ";
chomp ($_ = );
$config{'proxypassword'} = $_ || $config{'proxypassword'};
}
print "\nEnter directory to download binary package files to\n";
print "(relative to $methdir)\n";
while(1) {
print "[$config{'dldir'}] : ";
chomp($_ = );
s{/$}{};
$config{'dldir'} = $_ if ($_);
last if -d "$methdir/$config{'dldir'}";
print "$methdir/$config{'dldir'} is not a directory !\n";
}
}
sub add_site {
my $pas = 1;
my $user = "anonymous";
my $email = `whoami`;
chomp $email;
$email .= '@' . `cat /etc/mailname || dnsdomainname`;
chomp $email;
my $dir = "/debian";
push (@{$config{'site'}}, [ "", $dir, [ "dists/stable/main",
"dists/stable/contrib",
"dists/stable/non-free" ],
$pas, $user, $email ]);
edit_site($config{'site'}[@{$config{'site'}} - 1]);
}
sub edit_site {
my $site = shift;
local($_);
print "\nEnter ftp site [$site->[0]] : ";
chomp($_ = );
$site->[0] = $_ || $site->[0];
print "\nUse passive mode [" . ($site->[3] ? "y" : "n") ."] : ";
chomp($_ = );
$site->[3] = (/y/i ? 1 : 0) if ($_);
print "\nEnter username [$site->[4]] : ";
chomp($_ = );
$site->[4] = $_ || $site->[4];
print <[5]] : ";
chomp($_ = );
$site->[5] = $_ || $site->[5];
print "\nEnter debian directory [$site->[1]] : ";
chomp($_ = );
$site->[1] = $_ || $site->[1];
print "\nEnter space separated list of distributions to get\n";
print "[@{$site->[2]}] : ";
chomp($_ = );
$site->[2] = [ split(/\s+/) ] if $_;
}
sub yesno($$) {
my ($d, $msg) = @_;
my ($res, $r);
$r = -1;
$r = 0 if $d eq "n";
$r = 1 if $d eq "y";
die "Incorrect usage of yesno, stopped" if $r == -1;
while (1) {
print $msg, " [$d]: ";
$res = ;
$res =~ /^[Yy]/ and return 1;
$res =~ /^[Nn]/ and return 0;
$res =~ /^[ \t]*$/ and return $r;
print "Please enter one of the letters `y' or `n'\n";
}
}
##############################
sub do_connect {
my($ftpsite,$username,$pass,$ftpdir,$passive,
$useproxy,$proxyhost,$proxylogname,$proxypassword) = @_;
my($rpass,$remotehost,$remoteuser,$ftp);
TRY_CONNECT:
while(1) {
my $exit = 0;
if ($useproxy) {
$remotehost = $proxyhost;
$remoteuser = $username . "@" . $ftpsite;
} else {
$remotehost = $ftpsite;
$remoteuser = $username;
}
print "Connecting to $ftpsite...\n";
$ftp = Net::FTP->new($remotehost, Passive => $passive);
if(!$ftp || !$ftp->ok) {
print "Failed to connect\n";
$exit=1;
}
if (!$exit) {
# $ftp->debug(1);
if ($useproxy) {
print "Login on $proxyhost...\n";
$ftp->_USER($proxylogname);
$ftp->_PASS($proxypassword);
}
print "Login as $username...\n";
if ($pass eq "?") {
print "Enter password for ftp: ";
system("stty", "-echo");
$rpass = ;
chomp $rpass;
print "\n";
system("stty", "echo");
} else {
$rpass = $pass;
}
if(!$ftp->login($remoteuser, $rpass))
{ print $ftp->message() . "\n"; $exit=1; }
}
if (!$exit) {
print "Setting transfer mode to binary...\n";
if(!$ftp->binary()) { print $ftp->message . "\n"; $exit=1; }
}
if (!$exit) {
print "Cd to `$ftpdir'...\n";
if(!$ftp->cwd($ftpdir)) { print $ftp->message . "\n"; $exit=1; }
}
if ($exit) {
if (yesno ("y", "Retry connection at once")) {
next TRY_CONNECT;
} else {
die "error";
}
}
last TRY_CONNECT;
}
# if(!$ftp->pasv()) { print $ftp->message . "\n"; die "error"; }
return $ftp;
}
##############################
# assume server supports MDTM - will be adjusted if needed
my $has_mdtm = 1;
my %months = ('Jan', 0,
'Feb', 1,
'Mar', 2,
'Apr', 3,
'May', 4,
'Jun', 5,
'Jul', 6,
'Aug', 7,
'Sep', 8,
'Oct', 9,
'Nov', 10,
'Dec', 11);
sub do_mdtm {
my ($ftp, $file) = @_;
my ($time);
#if ($has_mdtm) {
$time = $ftp->mdtm($file);
# my $code=$ftp->code(); my $message=$ftp->message();
# print " [ $code: $message ] ";
if ($ftp->code() == 502 # MDTM not implemented
|| $ftp->code() == 500 # command not understood (SUN firewall)
) {
$has_mdtm = 0;
} elsif (!$ftp->ok()) {
return undef;
}
#}
if (! $has_mdtm) {
use Time::Local;
my @files = $ftp->dir($file);
if (($#files == -1) || ($ftp->code == 550)) { # No such file or directory
return undef;
}
# my $code=$ftp->code(); my $message=$ftp->message();
# print " [ $code: $message ] ";
# print "[$#files]";
# get the date components from the output of "ls -l"
if ($files[0] =~
/([^ ]+ *){5}[^ ]+ ([A-Z][a-z]{2}) ([ 0-9][0-9]) ([0-9 ][0-9][:0-9][0-9]{2})/) {
my($month_name, $day, $yearOrTime, $month, $hours, $minutes,
$year);
# what we can read
$month_name = $2;
$day = 0 + $3;
$yearOrTime = $4;
# translate the month name into number
$month = $months{$month_name};
# recognize time or year, and compute missing one
if ($yearOrTime =~ /([0-9]{2}):([0-9]{2})/) {
$hours = 0 + $1; $minutes = 0 + $2;
my @this_date = gmtime(time());
my $this_month = $this_date[4];
my $this_year = $this_date[5];
if ($month > $this_month) {
$year = $this_year - 1;
} else {
$year = $this_year;
}
} elsif ($yearOrTime =~ / [0-9]{4}/) {
$hours = 0; $minutes = 0;
$year = $yearOrTime - 1900;
} else {
die "Cannot parse year-or-time";
}
# build a system time
$time = timegm (0, $minutes, $hours, $day, $month, $year);
} else {
die "Regexp match failed on LIST output";
}
}
return $time;
}
1;
__END__
DebianNet.pm 0000666 00000031366 15077711155 0006761 0 ustar 00 # DebianNet.pm: a perl module to add entries to the /etc/inetd.conf file
#
# Copyright (C) 1995, 1996 Peter Tobias
# Ian Jackson
#
#
# DebianNet::add_service($newentry, $group);
# DebianNet::disable_service($service, $pattern);
# DebianNet::enable_service($service, $pattern);
# DebianNet::remove_service($entry);
#
package DebianNet;
require 5.6.1;
use Debconf::Client::ConfModule ':all';
use File::Temp qw/ tempfile /;
use File::Copy qw/ move /;
$inetdcf="/etc/inetd.conf";
$sep = "## ";
$version = "1.12";
$called_wakeup_inetd = 0;
sub add_service {
local($newentry, $group) = @_;
local($service, $searchentry, @inetd, $inetdconf, $found, $success);
unless (defined($newentry)) { return(-1) };
chomp($newentry);
if (defined $group) {
chomp($group);
} else {
$group = "OTHER";
}
$group =~ tr/a-z/A-Z/;
$newentry =~ s/\\t/\t/g;
($service = $newentry) =~ s/(\W*\w+)\s+.*/$1/;
($sservice = $service) =~ s/^#([A-Za-z].*)/$1/;
($searchentry = $newentry) =~ s/^$sep//;
$searchentry =~ s/^#([A-Za-z].*)/$1/;
# strip parameter from entry (e.g. -s /tftpboot)
# example: service dgram udp wait root /tcpd /prg -s /tftpboot";
$searchentry =~ s/^(\w\S+\W+\w+\W+\w\S+\W+\w\S+\W+\w\S+\W+\S+\W+\S+).*/$1/;
$searchentry =~ s/[ \t]+/ /g;
$searchentry =~ s/ /\\s+/g;
$searchentry =~ s@\\s\+/\S+\\s\+/\S+@\\s\+\\S\+\\s\+\\S\+@g;
if (open(INETDCONF,"$inetdcf")) {
@inetd=;
close(INETDCONF);
if (grep(m/^$sep$sservice\s+/,@inetd)) {
&enable_service($sservice);
} else {
if (grep(m/^$sservice\s+/,@inetd)) {
if (grep(m/^$sservice\s+/,@inetd) > 1) {
set("update-inetd/ask-several-entries", "true");
fset("update-inetd/ask-several-entries", "seen", "false");
settitle("update-inetd/title");
subst("update-inetd/ask-several-entries", "service", "$sservice");
subst("update-inetd/ask-several-entries", "sservice", "$sservice");
subst("update-inetd/ask-several-entries", "inetdcf", "$inetdcf");
input("high", "update-inetd/ask-several-entries");
@ret = go();
if ($ret[0] == 0) {
@ret = get("update-inetd/ask-several-entries");
exit(1) if ($ret[1] !~ m/true/i);
}
} elsif (!grep(m:^#?.*$searchentry.*:, @inetd)) {
set("update-inetd/ask-entry-present", "true");
fset("update-inetd/ask-entry-present", "seen", "false");
settitle("update-inetd/title");
subst("update-inetd/ask-entry-present", "service", "$sservice");
subst("update-inetd/ask-entry-present", "newentry", "$newentry");
subst("update-inetd/ask-entry-present", "sservice", "$sservice");
subst("update-inetd/ask-entry-present", "inetdcf", "$inetdcf");
my $lookslike = (grep(m/^$sservice\s+/,@inetd))[0];
$lookslike =~ s/\n//g;
subst("update-inetd/ask-entry-present", "lookslike", "$lookslike");
input("high", "update-inetd/ask-entry-present");
@ret = go();
if ($ret[0] == 0) {
@ret = get("update-inetd/ask-entry-present");
exit(1) if ($ret[1] !~ m/true/i);
}
}
} elsif (grep(m/^#\s*$sservice\s+/, @inetd) >= 1 or
(($service =~ s/^#//) and grep(m/^$service\s+/, @inetd)>=1)) {
print STDERR "Processing service \`$service' ... not enabled"
. " (entry is commented out by user)\n";
} else {
&printv("Processing service \`$sservice' ... added\n");
$inetdconf=1;
}
}
if ($inetdconf) {
my $init_svc_count = &scan_entries();
&printv("Number of currently enabled services: $init_svc_count\n");
my ($ICWRITE, $new_inetdcf) = tempfile("/tmp/inetdcfXXXXX", UNLINK => 0);
unless (defined($ICWRITE)) { die "Error creating temporary file: $!\n" }
&printv("Using tempfile $new_inetdcf\n");
open(ICREAD, "$inetdcf");
while() {
chomp;
if (/^#:$group:/) {
$found = 1;
};
if ($found and !(/[a-zA-Z#]/)) {
print ($ICWRITE "$newentry\n")
|| die "Error writing to $new_inetdcf: $!\n";
$found = 0;
$success = 1;
}
print $ICWRITE "$_\n";
}
close(ICREAD);
unless ($success) {
print ($ICWRITE "$newentry\n")
|| die "Error writing to $new_inetdcf: $!\n";
$success = 1;
}
close($ICWRITE) || die "Error closing $new_inetdcf: $!\n";
if ($success) {
move("$new_inetdcf","$inetdcf") ||
die "Error installing $new_inetdcf to $inetdcf: $!\n";
chmod(0644, "$inetdcf");
&wakeup_inetd(0,$init_svc_count);
&printv("New service(s) added\n");
} else {
&printv("No service(s) added\n");
unlink("$new_inetdcf")
|| die "Error removing $new_inetdcf: $!\n";
}
} else {
&printv("No service(s) added\n");
}
}
return(1);
}
sub remove_service {
my($service) = @_;
unless(defined($service)) { return(-1) };
chomp($service);
my $nlines_removed = 0;
if($service eq "") {
print STDERR "DebianNet::remove_service called with empty argument\n";
return(-1);
}
if (((&scan_entries("$service") > 1) or (&scan_entries("$sep$service") > 1))
and (not defined($multi))) {
set("update-inetd/ask-remove-entries", "false");
fset("update-inetd/ask-remove-entries", "seen", "false");
settitle("update-inetd/title");
subst("update-inetd/ask-remove-entries", "service", "$service");
subst("update-inetd/ask-remove-entries", "inetdcf", "$inetdcf");
input("high", "update-inetd/ask-remove-entries");
@ret = go();
if ($ret[0] == 0) {
@ret = get("update-inetd/ask-remove-entries");
return(1) if ($ret[1] =~ /false/i);
}
}
my ($ICWRITE, $new_inetdcf) = tempfile("/tmp/inetdcfXXXXX", UNLINK => 0);
unless (defined($ICWRITE)) { die "Error creating temporary file: $!\n" }
&printv("Using tempfile $new_inetdcf\n");
open(ICREAD, "$inetdcf");
RLOOP: while() {
chomp;
unless (/^$service\s+/ or /^$sep$service\s+/) {
print $ICWRITE "$_\n";
} else {
&printv("Removing line: \`$_'\n");
$nlines_removed += 1;
}
}
close(ICREAD);
close($ICWRITE);
if ($nlines_removed > 0) {
move("$new_inetdcf", "$inetdcf") ||
die "Error installing $new_inetdcf to $inetdcf: $!\n";
chmod(0644, "$inetdcf");
wakeup_inetd(1);
&printv("Number of service entries removed: $nlines_removed\n");
} else {
&printv("No service entries were removed\n");
unlink("$new_inetdcf") || die "Error removing $new_inetdcf: $!\n";
}
return(1);
}
sub disable_service {
my($service, $pattern) = @_;
unless (defined($service)) { return(-1) };
unless (defined($pattern)) { $pattern = ''; }
chomp($service);
my $nlines_disabled = 0;
if ((&scan_entries("$service", $pattern) > 1) and (not defined($multi))) {
set("update-inetd/ask-disable-entries", "false");
fset("update-inetd/ask-disable-entries", "seen", "false");
settitle("update-inetd/title");
subst("update-inetd/ask-disable-entries", "service", "$service");
subst("update-inetd/ask-disable-entries", "inetdcf", "$inetdcf");
input("high", "update-inetd/ask-disable-entries");
@ret = go();
if ($ret[0] == 0) {
@ret = get("update-inetd/ask-disable-entries");
return(1) if ($ret[1] =~ /false/i);
}
}
my ($ICWRITE, $new_inetdcf) = tempfile("/tmp/inetdcfXXXXX", UNLINK => 0);
unless (defined($ICWRITE)) { die "Error creating temporary file: $!\n" }
&printv("Using tempfile $new_inetdcf\n");
open(ICREAD, "$inetdcf");
DLOOP: while() {
chomp;
if (/^$service\s+\w+\s+/ and /$pattern/) {
&printv("Processing service \`$service' ... disabled\n");
$_ =~ s/^(.+)$/$sep$1/;
$nlines_disabled += 1;
}
print $ICWRITE "$_\n";
}
close(ICREAD);
close($ICWRITE) || die "Error closing $new_inetdcf: $!\n";
if ($nlines_disabled > 0) {
move("$new_inetdcf","$inetdcf") ||
die "Error installing new $inetdcf: $!\n";
chmod(0644, "$inetdcf");
wakeup_inetd(1);
&printv("Number of service entries disabled: $nlines_disabled\n");
} else {
&printv("No service entries were disabled\n");
unlink("$new_inetdcf") || die "Error removing $new_inetdcf: $!\n";
}
return(1);
}
sub enable_service {
my($service, $pattern) = @_;
unless (defined($service)) { return(-1) };
unless (defined($pattern)) { $pattern = ''; }
my $init_svc_count = &scan_entries();
my $nlines_enabled = 0;
chomp($service);
my ($ICWRITE, $new_inetdcf) = tempfile("/tmp/inetdXXXXX", UNLINK => 0);
unless (defined($ICWRITE)) { die "Error creating temporary file: $!\n" }
&printv("Using tempfile $new_inetdcf\n");
open(ICREAD, "$inetdcf");
while() {
chomp;
if (/^$sep$service\s+\w+\s+/ and /$pattern/) {
&printv("Processing service \`$service' ... enabled\n");
$_ =~ s/^$sep//;
$nlines_enabled += 1;
}
print $ICWRITE "$_\n";
}
close(ICREAD);
close($ICWRITE) || die "Error closing $new_inetdcf: $!\n";
if ($nlines_enabled > 0) {
move("$new_inetdcf","$inetdcf") ||
die "Error installing $new_inetdcf to $inetdcf: $!\n";
chmod(0644, "$inetdcf");
&wakeup_inetd(0,$init_svc_count);
&printv("Number of service entries enabled: $nlines_enabled\n");
} else {
&printv("No service entries were enabled\n");
unlink("$new_inetdcf") || die "Error removing $new_inetdcf: $!\n";
}
return(1);
}
sub wakeup_inetd {
my($removal,$init_svc_count) = @_;
my($pid);
my($action);
$called_wakeup_inetd = 1;
if ($removal) {
$action = 'force-reload';
} elsif ( defined($init_svc_count) and $init_svc_count == 0 ) {
$action = 'start';
} else {
$action = 'restart';
}
$fake_invocation = defined($ENV{"UPDATE_INETD_FAKE_IT"});
if (open(P,"/var/run/inetd.pid")) {
$pid=;
chomp($pid);
if (open(C,sprintf("/proc/%d/stat",$pid))) {
$_=;
if (m/^\d+ \((rl|inetutils-)?inetd\)/) {
&printv("About to send SIGHUP to inetd (pid: $pid)\n");
unless ($fake_invocation) {
kill(1,$pid);
}
} else {
print STDERR "/var/run/inetd.pid does not have a valid pid!";
print STDERR "Please investigate and restart inetd manually.";
}
close(C);
}
close(P);
} else {
$_ = glob "/etc/init.d/*inetd";
if (m/\/etc\/init\.d\/(.*inetd)/ or $fake_invocation) {
&printv("About to $action inetd via invoke-rc.d\n");
my $service = $1;
unless ($fake_invocation) {
# If we were called by a shell script that also uses
# debconf, the pipe to the debconf frontend is fd 3 as
# well as fd 1 (stdout). Ensure that fd 3 is not
# inherited by invoke-rc.d and inetd, as that will
# cause debconf to hang (bug #589487). Don't let them
# confuse debconf via stdout either.
system("invoke-rc.d $service $action >/dev/null 3>&-");
}
}
}
return(1);
}
sub scan_entries {
my ($service, $pattern) = @_;
unless (defined($service)) { $service = '[^#\s]+'; }
unless (defined($pattern)) { $pattern = ''; }
my $counter = 0;
open(ICREAD, "$inetdcf");
SLOOP: while () {
$counter++ if (/^$service\s+/ and /$pattern/);
}
close(ICREAD);
return($counter);
}
sub printv {
print STDERR @_ if (defined($verbose));
}
1;
Dpkg/Arch.pm 0000666 00000017240 15077711155 0006665 0 ustar 00 # This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see ) {
if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
$cputable{$1} = $2;
$cputable_re{$1} = $3;
$cpubits{$1} = $4;
$cpuendian{$1} = $5;
push @cpu, $1;
}
}
close CPUTABLE;
}
sub read_ostable
{
local $_;
local $/ = "\n";
open OSTABLE, "$pkgdatadir/ostable"
or syserr(_g("cannot open %s"), "ostable");
while () {
if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
$ostable{$1} = $2;
$ostable_re{$1} = $3;
push @os, $1;
}
}
close OSTABLE;
}
sub read_triplettable()
{
read_cputable() if (!@cpu);
local $_;
local $/ = "\n";
open TRIPLETTABLE, "$pkgdatadir/triplettable"
or syserr(_g("cannot open %s"), "triplettable");
while () {
if (m/^(?!\#)(\S+)\s+(\S+)/) {
my $debtriplet = $1;
my $debarch = $2;
if ($debtriplet =~ //) {
foreach my $_cpu (@cpu) {
(my $dt = $debtriplet) =~ s//$_cpu/;
(my $da = $debarch) =~ s//$_cpu/;
$debarch_to_debtriplet{$da} = $dt;
$debtriplet_to_debarch{$dt} = $da;
}
} else {
$debarch_to_debtriplet{$2} = $1;
$debtriplet_to_debarch{$1} = $2;
}
}
}
close TRIPLETTABLE;
}
sub debtriplet_to_gnutriplet(@)
{
read_cputable() if (!@cpu);
read_ostable() if (!@os);
my ($abi, $os, $cpu) = @_;
return undef unless defined($abi) && defined($os) && defined($cpu) &&
exists($cputable{$cpu}) && exists($ostable{"$abi-$os"});
return join("-", $cputable{$cpu}, $ostable{"$abi-$os"});
}
sub gnutriplet_to_debtriplet($)
{
my ($gnu) = @_;
return undef unless defined($gnu);
my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2);
return undef unless defined($gnu_cpu) && defined($gnu_os);
read_cputable() if (!@cpu);
read_ostable() if (!@os);
my ($os, $cpu);
foreach my $_cpu (@cpu) {
if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) {
$cpu = $_cpu;
last;
}
}
foreach my $_os (@os) {
if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) {
$os = $_os;
last;
}
}
return undef if !defined($cpu) || !defined($os);
return (split(/-/, $os, 2), $cpu);
}
sub debtriplet_to_debarch(@)
{
read_triplettable() if (!%debtriplet_to_debarch);
my ($abi, $os, $cpu) = @_;
if (!defined($abi) || !defined($os) || !defined($cpu)) {
return undef;
} elsif (exists $debtriplet_to_debarch{"$abi-$os-$cpu"}) {
return $debtriplet_to_debarch{"$abi-$os-$cpu"};
} else {
return undef;
}
}
sub debarch_to_debtriplet($)
{
read_triplettable() if (!%debarch_to_debtriplet);
local ($_) = @_;
my $arch;
if (/^linux-([^-]*)/) {
# XXX: Might disappear in the future, not sure yet.
$arch = $1;
} else {
$arch = $_;
}
my $triplet = $debarch_to_debtriplet{$arch};
if (defined($triplet)) {
return split('-', $triplet, 3);
} else {
return undef;
}
}
sub debarch_to_gnutriplet($)
{
my ($arch) = @_;
return debtriplet_to_gnutriplet(debarch_to_debtriplet($arch));
}
sub gnutriplet_to_debarch($)
{
my ($gnu) = @_;
return debtriplet_to_debarch(gnutriplet_to_debtriplet($gnu));
}
sub debwildcard_to_debtriplet($)
{
local ($_) = @_;
if (/any/) {
if (/^([^-]*)-([^-]*)-(.*)/) {
return ($1, $2, $3);
} elsif (/^([^-]*)-([^-]*)$/) {
return ('any', $1, $2);
} else {
return ($_, $_, $_);
}
} else {
return debarch_to_debtriplet($_);
}
}
sub debarch_to_cpuattrs($)
{
my ($arch) = @_;
my ($abi, $os, $cpu) = debarch_to_debtriplet($arch);
if (defined($cpu)) {
return ($cpubits{$cpu}, $cpuendian{$cpu});
} else {
return undef;
}
}
sub debarch_eq($$)
{
my ($a, $b) = @_;
return 1 if ($a eq $b);
my @a = debarch_to_debtriplet($a);
my @b = debarch_to_debtriplet($b);
return 0 if grep(!defined, (@a, @b));
return ($a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2]);
}
sub debarch_is($$)
{
my ($real, $alias) = @_;
return 1 if ($alias eq $real or $alias eq 'any');
my @real = debarch_to_debtriplet($real);
my @alias = debwildcard_to_debtriplet($alias);
return 0 if grep(!defined, (@real, @alias));
if (($alias[0] eq $real[0] || $alias[0] eq 'any') &&
($alias[1] eq $real[1] || $alias[1] eq 'any') &&
($alias[2] eq $real[2] || $alias[2] eq 'any')) {
return 1;
}
return 0;
}
1;
Dpkg/Vendor/Ubuntu.pm 0000666 00000012271 15077711155 0010526 0 ustar 00 # Copyright © 2008 Ian Jackson
# Copyright © 2008 Canonical, Ltd.
# written by Colin Watson
# Copyright © 2008 James Westby
# Copyright © 2009 Raphaël Hertzog
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
=cut
1;
Dpkg/Control.pm 0000666 00000012721 15077711155 0007427 0 ustar 00 # Copyright © 2007-2009 Raphaël Hertzog
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see