home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / Debconf / Template.pm < prev    next >
Encoding:
Perl POD Document  |  2008-10-10  |  7.7 KB  |  339 lines
  1. #!/usr/bin/perl -w
  2. # This file was preprocessed, do not edit!
  3.  
  4.  
  5. package Debconf::Template;
  6. use strict;
  7. use POSIX;
  8. use FileHandle;
  9. use Debconf::Gettext;
  10. use Text::Wrap;
  11. use Text::Tabs;
  12. use Debconf::Db;
  13. use Debconf::Iterator;
  14. use Debconf::Question;
  15. use fields qw(template);
  16. use Debconf::Log q{:all};
  17. use Debconf::Encoding;
  18.  
  19. our %template;
  20. $Debconf::Template::i18n=1;
  21.  
  22. our %known_field = map { $_ => 1 }
  23.     qw{template description choices default type};
  24.  
  25. binmode(STDOUT);
  26. binmode(STDERR);
  27.     
  28.  
  29.  
  30. sub new {
  31.     my Debconf::Template $this=shift;
  32.     my $template=shift || die "no template name specified";
  33.     my $owner=shift || 'unknown';
  34.     my $type=shift || die "no template type specified";
  35.     
  36.     if ($Debconf::Db::templates->exists($template) and
  37.         $Debconf::Db::templates->owners($template)) {
  38.         my $q=Debconf::Question->get($template);
  39.         $q->addowner($owner, $type) if $q;
  40.  
  41.         my @owners=$Debconf::Db::templates->owners($template);
  42.         foreach my $question (@owners) {
  43.             my $q=Debconf::Question->get($question);
  44.             if (! $q) {
  45.                 warn sprintf(gettext("warning: possible database corruption. Will attempt to repair by adding back missing question %s."), $question);
  46.                 my $newq=Debconf::Question->new($question, $owner, $type);
  47.                 $newq->template($template);
  48.             }
  49.         }
  50.         
  51.         $this = fields::new($this);
  52.         $this->{template}=$template;
  53.         return $template{$template}=$this;
  54.     }
  55.  
  56.     unless (ref $this) {
  57.         $this = fields::new($this);
  58.     }
  59.     $this->{template}=$template;
  60.  
  61.     if ($Debconf::Db::config->exists($template)) {
  62.         my $q=Debconf::Question->get($template);
  63.         $q->addowner($owner, $type) if $q;
  64.     }
  65.     else {
  66.         my $q=Debconf::Question->new($template, $owner, $type);
  67.         $q->template($template);
  68.     }
  69.     
  70.     return unless $Debconf::Db::templates->addowner($template, $template, $type);
  71.  
  72.     $Debconf::Db::templates->setfield($template, 'type', $type);
  73.     return $template{$template}=$this;
  74. }
  75.  
  76.  
  77. sub get {
  78.     my Debconf::Template $this=shift;
  79.     my $template=shift;
  80.     return $template{$template} if exists $template{$template};
  81.     if ($Debconf::Db::templates->exists($template)) {
  82.         $this = fields::new($this);
  83.         $this->{template}=$template;
  84.         return $template{$template}=$this;
  85.     }
  86.     return undef;
  87. }
  88.  
  89.  
  90. sub i18n {
  91.     my $class=shift;
  92.     $Debconf::Template::i18n=shift;
  93. }
  94.  
  95.  
  96. sub load {
  97.     my $this=shift;
  98.     my $file=shift;
  99.  
  100.     my @ret;
  101.     my $fh;
  102.  
  103.     if (ref $file) {
  104.         $fh=$file;
  105.     }
  106.     else {
  107.         $fh=FileHandle->new($file) || die "$file: $!";
  108.     }
  109.     local $/="\n\n"; # read a template at a time.
  110.     while (<$fh>) {
  111.         my %data;
  112.         
  113.         my $save = sub {
  114.             my $field=shift;
  115.             my $value=shift;
  116.             my $extended=shift;
  117.             my $file=shift;
  118.  
  119.             $extended=~s/\n+$//;
  120.  
  121.             if ($field ne '') {
  122.                 if (exists $data{$field}) {
  123.                     die sprintf(gettext("Template #%s in %s has a duplicate field \"%s\" with new value \"%s\". Probably two templates are not properly separated by a lone newline.\n"), $., $file, $field, $value);
  124.                 }
  125.                 $data{$field}=$value;
  126.                 $data{"extended_$field"}=$extended
  127.                     if length $extended;
  128.             }
  129.         };
  130.  
  131.         s/^\n+//;
  132.         s/\n+$//;
  133.         my ($field, $value, $extended)=('', '', '');
  134.         foreach my $line (split "\n", $_) {
  135.             chomp $line;
  136.             if ($line=~/^([-_.A-Za-z0-9]*):\s?(.*)/) {
  137.                 $save->($field, $value, $extended, $file);
  138.                 $field=lc $1;
  139.                 $value=$2;
  140.                 $value=~s/\s*$//;
  141.                 $extended='';
  142.                 my $basefield=$field;
  143.                 $basefield=~s/-.+$//;
  144.                 if (! $known_field{$basefield}) {
  145.                     warn sprintf(gettext("Unknown template field '%s', in stanza #%s of %s\n"), $field, $., $file);
  146.                 }
  147.             }
  148.             elsif ($line=~/^\s\.$/) {
  149.                 $extended.="\n\n";
  150.             }
  151.             elsif ($line=~/^\s(\s+.*)/) {
  152.                 my $bit=$1;
  153.                 $bit=~s/\s*$//;
  154.                 $extended.="\n" if length $extended &&
  155.                                    $extended !~ /[\n ]$/;
  156.                 $extended.=$bit."\n";
  157.             }
  158.             elsif ($line=~/^\s(.*)/) {
  159.                 my $bit=$1;
  160.                 $bit=~s/\s*$//;
  161.                 $extended.=' ' if length $extended &&
  162.                                   $extended !~ /[\n ]$/;
  163.                 $extended.=$bit;
  164.             }
  165.             else {
  166.                 die sprintf(gettext("Template parse error near `%s', in stanza #%s of %s\n"), $line, $., $file);
  167.             }
  168.         }
  169.         $save->($field, $value, $extended, $file);
  170.  
  171.         die sprintf(gettext("Template #%s in %s does not contain a 'Template:' line\n"), $., $file)
  172.             unless $data{template};
  173.  
  174.         my $template=$this->new($data{template}, @_, $data{type});
  175.         $template->clearall;
  176.         foreach my $key (keys %data) {
  177.             next if $key eq 'template';
  178.             $template->$key($data{$key});
  179.         }
  180.         push @ret, $template;
  181.     }
  182.  
  183.     return @ret;
  184. }
  185.                     
  186.  
  187. sub template {
  188.     my $this=shift;
  189.  
  190.     return $this->{template};
  191. }
  192.  
  193.  
  194. sub fields {
  195.     my $this=shift;
  196.  
  197.     return $Debconf::Db::templates->fields($this->{template});
  198. }
  199.  
  200.  
  201. sub clearall {
  202.     my $this=shift;
  203.  
  204.     foreach my $field ($this->fields) {
  205.         $Debconf::Db::templates->removefield($this->{template}, $field);
  206.     }
  207. }
  208.  
  209.  
  210. sub stringify {
  211.     my $this=shift;
  212.  
  213.     my @templatestrings;
  214.     foreach (ref $this ? $this : @_) {
  215.         my $data='';
  216.         foreach my $key ('template', 'type',
  217.             (grep { $_ ne 'template' && $_ ne 'type'} sort $_->fields)) {
  218.             next if $key=~/^extended_/;
  219.             if ($key =~ m/-[a-z]{2}_[a-z]{2}(-fuzzy)?$/) {
  220.                 my $casekey=$key;
  221.                 $casekey=~s/([a-z]{2})(-fuzzy|)$/uc($1).$2/eg;
  222.                 $data.=ucfirst($casekey).": ".$_->$key."\n";
  223.             }
  224.             else {
  225.                 $data.=ucfirst($key).": ".$_->$key."\n";
  226.             }
  227.             my $e="extended_$key";
  228.             my $ext=$_->$e;
  229.             if (defined $ext) {
  230.                 $Text::Wrap::break = qr/\n|\s(?=\S)/;
  231.                 my $extended=expand(wrap(' ', ' ', $ext));
  232.                 $extended=~s/(\n )+\n/\n .\n/g;
  233.                 $data.=$extended."\n" if length $extended;
  234.             }
  235.         }
  236.         push @templatestrings, $data;
  237.     }
  238.     return join("\n", @templatestrings);
  239. }
  240.  
  241.  
  242. sub _addterritory {
  243.     my $locale=shift;
  244.     my $territory=shift;
  245.     $locale=~s/^([^_@.]+)/$1$territory/;
  246.     return $locale;
  247. }
  248. sub _addcharset {
  249.     my $locale=shift;
  250.     my $charset=shift;
  251.     $locale=~s/^([^@.]+)/$1$charset/;
  252.     return $locale;
  253. }
  254. sub _getlocalelist {
  255.     my $locale=shift;
  256.     $locale=~s/(@[^.]+)//;
  257.     my $modifier=$1;
  258.     my ($lang, $territory, $charset)=($locale=~m/^
  259.          ([^_@.]+)      #  Language
  260.          (_[^_@.]+)?    #  Territory
  261.          (\..+)?        #  Charset
  262.          /x);
  263.     my (@ret) = ($lang);
  264.     @ret = map { $_.$modifier, $_} @ret if defined $modifier;
  265.     @ret = map { _addterritory($_,$territory), $_} @ret if defined $territory;
  266.     @ret = map { _addcharset($_,$charset), $_} @ret if defined $charset;
  267.     return @ret;
  268. }
  269.  
  270. sub _getlangs {
  271.     my $language=setlocale(5); # LC_MESSAGES
  272.     my @langs = ();
  273.     if (exists $ENV{LANGUAGE} && $ENV{LANGUAGE} ne '') {
  274.         foreach (split(/:/, $ENV{LANGUAGE})) {
  275.             push (@langs, _getlocalelist($_));
  276.         }
  277.     }
  278.     return @langs, _getlocalelist($language);
  279. }
  280.  
  281. my @langs=map { lc $_ } _getlangs();
  282.  
  283. sub AUTOLOAD {
  284.     (my $field = our $AUTOLOAD) =~ s/.*://;
  285.     no strict 'refs';
  286.     *$AUTOLOAD = sub {
  287.         my $this=shift;
  288.         if (@_) {
  289.             return $Debconf::Db::templates->setfield($this->{template}, $field, shift);
  290.         }
  291.         
  292.         my $ret;
  293.  
  294.         if ($Debconf::Template::i18n && @langs) {
  295.             foreach my $lang (@langs) {
  296.                 $ret=$Debconf::Db::templates->getfield($this->{template}, $field.'-'.$lang);
  297.                 return $ret if defined $ret;
  298.                 
  299.                 if ($Debconf::Encoding::charmap) {
  300.                     foreach my $f ($Debconf::Db::templates->fields($this->{template})) {
  301.                         if ($f =~ /^\Q$field-$lang\E\.(.+)/) {
  302.                             my $encoding = $1;
  303.                             $ret = Debconf::Encoding::convert($encoding, $Debconf::Db::templates->getfield($this->{template}, lc($f)));
  304.                             return $ret if defined $ret;
  305.                         }
  306.                     }
  307.                 }
  308.             }
  309.         } elsif (not $Debconf::Template::i18n && $field !~ /-c$/i) {
  310.             $ret=$Debconf::Db::templates->getfield($this->{template}, $field.'-c');
  311.             return $ret if defined $ret;
  312.         }
  313.  
  314.         $ret=$Debconf::Db::templates->getfield($this->{template}, $field);
  315.         return $ret if defined $ret;
  316.  
  317.         if ($field =~ /-/) {
  318.             (my $plainfield = $field) =~ s/-.*//;
  319.             $ret=$Debconf::Db::templates->getfield($this->{template}, $plainfield);
  320.             return $ret if defined $ret;
  321.             return '';
  322.         }
  323.  
  324.         return '';
  325.     };
  326.     goto &$AUTOLOAD;
  327. }
  328.  
  329. sub DESTROY {}
  330.  
  331. use overload
  332.     '""' => sub {
  333.         my $template=shift;
  334.         $template->template;
  335.     };
  336.  
  337.  
  338. 1
  339.