home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / Debconf / Client / ConfModule.pm
Encoding:
Perl POD Document  |  2006-07-24  |  3.8 KB  |  165 lines
  1. #!/usr/bin/perl -w
  2.  
  3. =head1 NAME
  4.  
  5. Debconf::Client::ConfModule - client module for ConfModules
  6.  
  7. =head1 SYNOPSIS
  8.  
  9.  use Debconf::Client::ConfModule ':all';
  10.  version('2.0');
  11.  my $capb=capb('backup');
  12.  input("medium", "foo/bar");
  13.  my @ret=go();
  14.  if ($ret[0] == 30) {
  15.      # Back button pressed.
  16.      ...
  17.  }
  18.  ...
  19.  
  20. =head1 DESCRIPTION
  21.  
  22. This is a module to ease writing ConfModules for Debian's configuration
  23. management system. It can communicate with a FrontEnd via the debconf
  24. protocol (which is documented in full in the debconf_specification in
  25. Debian policy).
  26.  
  27. The design is that each command in the protocol is represented by one
  28. function in this module (with the name lower-cased).  Call the function and
  29. pass in any parameters you want to follow the command. If the function is
  30. called in scalar context, it will return any textual return code. If it is
  31. called in list context, an array consiting of the numeric return code and
  32. the textual return code will be returned.
  33.  
  34. This module uses Exporter to export all functions it defines. To import
  35. everything, simply import ":all".
  36.  
  37. =over 4
  38.  
  39. =cut
  40.  
  41. package Debconf::Client::ConfModule;
  42. use strict;
  43. use base qw(Exporter);
  44.  
  45. # List all valid commands here.
  46. our @EXPORT_OK=qw(version capb stop reset title input beginblock endblock go
  47.           unset set get register unregister clear previous_module
  48.           start_frontend fset fget subst purge metaget visible exist
  49.           settitle info progress);
  50.  
  51. # Import :all to get everything.           
  52. our %EXPORT_TAGS = (all => [@EXPORT_OK]);
  53.  
  54. # Set up valid command lookup hash.
  55. my %commands;
  56. map { $commands{uc $_}=1; } @EXPORT_OK;
  57.  
  58. # Unbuffered output is required.
  59. $|=1;
  60.  
  61. =item import
  62.  
  63. Ensure that a FrontEnd is running.  It's a little hackish. If
  64. DEBIAN_HAS_FRONTEND is set, a FrontEnd is assumed to be running.
  65. If not, one is started up automatically and stdin and out are
  66. connected to it. Note that this function is always run when the
  67. module is loaded in the usual way.
  68.  
  69. =cut
  70.  
  71. sub import {
  72.     if (! $ENV{DEBIAN_HAS_FRONTEND}) {
  73.         $ENV{PERL_DL_NONLAZY}=1;
  74.         if (exists $ENV{DEBCONF_USE_CDEBCONF} and
  75.             $ENV{DEBCONF_USE_CDEBCONF} ne '') {
  76.             exec "/usr/lib/cdebconf/debconf", $0, @ARGV;
  77.         } else {
  78.             exec "/usr/share/debconf/frontend", $0, @ARGV;
  79.         }
  80.     }
  81.  
  82.     # Make the Exporter still work.
  83.     Debconf::Client::ConfModule->export_to_level(1, @_);
  84.  
  85.     # A truly gross hack. This is only needed if
  86.     # /usr/share/debconf/confmodule is loaded, and then this
  87.     # perl module is used. In that case, this module needs to write
  88.     # to fd #3, rather than stdout. See changelog 0.3.74.
  89.     if (exists $ENV{DEBCONF_REDIR} && $ENV{DEBCONF_REDIR}) {
  90.         open(STDOUT,">&3");
  91.     }
  92. }
  93.  
  94. =item stop
  95.  
  96. The frontend doesn't send a return code here, so we cannot try to read it
  97. or we'll block.
  98.  
  99. =cut
  100.  
  101. sub stop {
  102.     print "STOP\n";
  103.     return;
  104. }
  105.  
  106. =item AUTOLOAD
  107.  
  108. Creates handler functions for commands on the fly.
  109.  
  110. =cut
  111.  
  112. sub AUTOLOAD {
  113.     my $command = uc our $AUTOLOAD;
  114.     $command =~ s|.*:||; # strip fully-qualified portion
  115.  
  116.     die "Unsupported command `$command'."
  117.         unless $commands{$command};
  118.     
  119.     no strict 'refs';
  120.     *$AUTOLOAD = sub {
  121.         my $c=join (' ', $command, @_);
  122.     
  123.         # Newlines in input can really badly confuse the protocol, so
  124.         # detect and warn.
  125.         if ($c=~m/\n/) {
  126.             warn "Warning: Newline present in parameters passed to debconf.\n";
  127.             warn "This will probably cause strange things to happen!\n";
  128.         }
  129.  
  130.         print "$c\n";
  131.         my $ret=<STDIN>;
  132.         chomp $ret;
  133.         my @ret=split(/\s/, $ret, 2);
  134.         if ($ret[0] eq '1') {
  135.             # escaped data
  136.             local $_;
  137.             my $unescaped='';
  138.             for (split /(\\.)/, $ret[1]) {
  139.                 s/\\(.)/$1 eq "n" ? "\n" : $1/eg;
  140.                 $unescaped.=$_;
  141.             }
  142.             $ret[0]='0';
  143.             $ret[1]=$unescaped;
  144.         }
  145.         return @ret if wantarray;
  146.         return $ret[1];
  147.     };
  148.     goto &$AUTOLOAD;
  149. }
  150.  
  151. =back
  152.  
  153. =head1 SEE ALSO
  154.  
  155. The debconf specification
  156. (/usr/share/doc/debian-policy/debconf_specification.txt.gz).
  157.  
  158. =head1 AUTHOR
  159.  
  160. Joey Hess <joeyh@debian.org>
  161.  
  162. =cut
  163.  
  164. 1
  165.