scripts/debpkg.pl

   1 #! /usr/bin/perl -w
   2
   3 # Perl version of Christoph Lameter's debpkg program.
   4 # Written by Julian Gilbey, December 1998.
   5
   6 # Copyright 1999, Julian Gilbey
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
  20
  21
  22 # All this program does is to check that it is either running as root
  23 # or setuid root, and then exec dpkg with the command line options.
  24
  25 # As this may be running setuid, we make sure to clean out the
  26 # environment before we go further.  Also wise for building the
  27 # packages, anyway.  We don't put /usr/local/bin in the PATH as Debian
  28 # programs will presumably be built without the use of any locally
  29 # installed programs.  This could be changed, but in which case,
  30 # you probably want to add /usr/local/bin at the END so that you don't
  31 # get any unexpected behaviour.
  32
  33 use 5.003;
  34 use File::Basename;
  35
  36 my $progname = basename($0);
  37
  38 # Predeclare functions
  39 sub fatal($);
  40
  41 my $usage = "Usage: $progname --help|--version|dpkg-options\n";
  42
  43 my $version = <<"EOF";
  44 This is $progname, from the Debian devscripts package, version ###VERSION###
  45 This code is copyright 1999 by Julian Gilbey, all rights reserved.
  46 Based on code by Christoph Lameter.
  47 This program comes with ABSOLUTELY NO WARRANTY.
  48 You are free to redistribute this code under the terms of the
  49 GNU General Public License, version 2 or later.
  50 EOF
  51
  52 ##
  53 ## handle command-line options
  54 ##
  55 if (! @ARGV) { print STDERR $usage; exit 1; }
  56 if ($ARGV[0] eq '--help') { print $usage; exit 0; }
  57 if ($ARGV[0] eq '--version') { print $version; exit 0; }
  58
  59 # We *do* preserve locale variables; dpkg should know how to handle
  60 # them, and anyone running this with root privileges has total power
  61 # over the system anyway, so doesn't really need to worry about forging
  62 # locale data.  We don't try to preserve TEXTDOMAIN and the like.
  63 foreach $var (keys %ENV) {
  64         delete $ENV{$var} unless
  65                 $var =~ /^(PATH|TERM|HOME|LOGNAME|LANG)$/ or
  66                         $var =~ /^LC_[A-Z]+$/;
  67 }
  68
  69 $ENV{'PATH'} = "/usr/sbin:/usr/bin:/sbin:/bin:/usr/bin/X11";
  70 # $ENV{'PATH'} = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/bin/X11";
  71 $ENV{'TERM'}='dumb' unless defined $ENV{'TERM'};
  72
  73 # Pick up superuser privileges if we are running setuid root
  74 if ( $< != 0 && $> == 0 ) { $< = $>; }
  75 fatal "debpkg is only useful if it is run by root or setuid root!"
  76         if $< != 0;
  77
  78 # Pick up group 'root'
  79 $( = $) = 0;
  80
  81 # @ARGV is tainted, so we need to untaint it.  Don't bother doing any
  82 # checking; anyone running this as root can do anything anyway.
  83 my @clean_argv = map { /^(.*)$/ && $1; } @ARGV;
  84 exec 'dpkg', @clean_argv or fatal "Couldn't exec dpkg: $!\n";
  85
  86 ###### Subroutines
  87
  88 sub fatal($) {
  89     my ($pack,$file,$line);
  90     ($pack,$file,$line) = caller();
  91     (my $msg = "$progname: fatal error at line $line:\n@_\n") =~ tr/\0//d;
  92          $msg =~ s/\n\n$/\n/;
  93     die $msg;
  94 }