"Fossies" - the Fresh Open Source Software Archive

Member "alien-8.95/Alien/Package/Deb.pm" (10 Sep 2015, 19774 Bytes) of package /linux/misc/alien_8.95.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Deb.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 8.94_vs_8.95.

    1 #!/usr/bin/perl -w
    2 
    3 =head1 NAME
    4 
    5 Alien::Package::Deb - an object that represents a deb package
    6 
    7 =cut
    8 
    9 package Alien::Package::Deb;
   10 use strict;
   11 use base qw(Alien::Package);
   12 use List::Util qw(first);
   13 
   14 =head1 DESCRIPTION
   15 
   16 This is an object class that represents a deb package. It is derived from
   17 Alien::Package.
   18 
   19 =head1 FIELDS
   20 
   21 =over 4
   22 
   23 =item have_dpkg_deb
   24 
   25 Set to a true value if dpkg-deb is available. 
   26 
   27 =item deb_member_list
   28 
   29 Set to the list of member names in the deb package.
   30 
   31 =item dirtrans
   32 
   33 After the build stage, set to a hash reference of the directories we moved
   34 files from and to, so these moves can be reverted in the cleantree stage.
   35 
   36 =item fixperms
   37 
   38 If this is set to true, the generated debian/rules will run dh_fixperms.
   39 
   40 =back
   41 
   42 =head1 METHODS
   43 
   44 =over 4
   45 
   46 =item init
   47 
   48 Sets have_dpkg_deb if dpkg-deb is in the path. I prefer to use dpkg-deb,
   49 if it is available since it is a lot more future-proof.
   50 
   51 =cut
   52 
   53 sub _inpath {
   54     my $this=shift;
   55     my $program=shift;
   56 
   57     foreach (split(/:/,$ENV{PATH})) {
   58         if (-x "$_/$program") {
   59             return 1;
   60         }
   61     }
   62     return '';
   63 }
   64 
   65 sub init {
   66     my $this=shift;
   67     $this->SUPER::init(@_);
   68 
   69     $this->have_dpkg_deb($this->_inpath('dpkg-deb'));
   70 }
   71 
   72 =item checkfile
   73 
   74 Detect deb files by their extension.
   75 
   76 =cut
   77 
   78 sub checkfile {
   79     my $this=shift;
   80     my $file=shift;
   81 
   82     return $file =~ m/.*\.u?deb$/;
   83 }
   84 
   85 =item install
   86 
   87 Install a deb with dpkg. Pass in the filename of the deb to install.
   88 
   89 =cut
   90 
   91 sub install {
   92     my $this=shift;
   93     my $deb=shift;
   94 
   95     my $v=$Alien::Package::verbose;
   96     $Alien::Package::verbose=2;
   97     $this->do("dpkg", "--no-force-overwrite", "-i", $deb)
   98         or die "Unable to install";
   99     $Alien::Package::verbose=$v;
  100 }
  101 
  102 =item test
  103 
  104 Test a deb with lintian. Pass in the filename of the deb to test.
  105 
  106 =cut
  107 
  108 sub test {
  109     my $this=shift;
  110     my $deb=shift;
  111 
  112     if ($this->_inpath("lintian")) {
  113         # Ignore some lintian warnings that don't matter for
  114         # aliened packages.
  115         return map { s/\n//; $_ }
  116                grep {
  117                     ! /unknown-section alien/
  118                } $this->runpipe(1, "lintian '$deb'");
  119     }
  120     else {
  121         return "lintian not available, so not testing";
  122     }
  123 }
  124 
  125 =item get_deb_member_list
  126 
  127 Helper method. Pass it the name of the deb and it will return the list of
  128 ar members.
  129 
  130 =cut
  131 
  132 sub get_deb_member_list {
  133     my $this=shift;
  134     my $file=$this->filename;
  135     my $members=$this->deb_member_list;
  136 
  137     unless (defined $members) {
  138         $members = [ map { chomp; $_ } $this->runpipe(1, "ar -t '$file'") ];
  139         $this->deb_member_list($members);
  140     }
  141 
  142     return @{$members};
  143 }
  144 
  145 =item getcontrolfile
  146 
  147 Helper method. Pass it the name of a control file, and it will pull it out
  148 of the deb and return it.
  149 
  150 =cut
  151 
  152 sub getcontrolfile {
  153     my $this=shift;
  154     my $controlfile=shift;
  155     my $file=$this->filename;
  156     
  157     if ($this->have_dpkg_deb) {
  158         return $this->runpipe(1, "dpkg-deb --info '$file' $controlfile 2>/dev/null");
  159     }
  160     else {
  161         # Solaris tar doesn't support O
  162         sub tar_out {
  163             my $file = shift;
  164 
  165             return "(mkdir /tmp/tar_out.$$ &&".
  166                 " cd /tmp/tar_out.$$ &&".
  167                 " tar xf - './$file' &&".
  168                 " cat '$file'; cd /; rm -rf /tmp/tar_out.$$)";
  169         }
  170         my $controlcomp;
  171         my $controlmember = first { /^control\.tar/ }
  172                     $this->get_deb_member_list;
  173         if (! defined $controlmember) {
  174             die 'Cannot find control member!';
  175         } elsif ($controlmember eq 'control.tar.gz') {
  176             $controlcomp = 'gzip -dc';
  177         } elsif ($controlmember eq 'control.tar.xz') {
  178             $controlcomp = 'xz -dc';
  179         } elsif ($controlmember eq 'control.tar') {
  180             $controlcomp = 'cat';
  181         } else {
  182             die 'Unknown control member!';
  183         }
  184         my $getcontrol = "ar -p '$file' $controlmember | $controlcomp | ".tar_out($controlfile)." 2>/dev/null";
  185         return $this->runpipe(1, $getcontrol);
  186     }
  187 }
  188 
  189 =item get_datamember_cmd
  190 
  191 Helper method. Pass it the name of the deb and it will return the raw
  192 command needed to extract the data.tar member.
  193 
  194 =cut
  195 
  196 sub get_datamember_cmd {
  197     my $this=shift;
  198     my $file=$this->filename;
  199 
  200     my $datacomp;
  201     my $datamember = first { /^data\.tar/ }
  202              $this->get_deb_member_list;
  203     if (! defined $datamember) {
  204         die 'Cannot find data member!';
  205     } elsif ($datamember eq 'data.tar.gz') {
  206         $datacomp = 'gzip -dc';
  207     } elsif ($datamember eq 'data.tar.bz2') {
  208         $datacomp = 'bzip2 -dc';
  209     } elsif ($datamember eq 'data.tar.xz') {
  210         $datacomp = 'xz -dc';
  211     } elsif ($datamember eq 'data.tar.lzma') {
  212         $datacomp = 'xz -dc';
  213     } elsif ($datamember eq 'data.tar') {
  214         $datacomp = 'cat';
  215     } else {
  216         die 'Unknown data member!';
  217     }
  218 
  219     return "ar -p '$file' $datamember | $datacomp";
  220 }
  221 
  222 =item scan
  223 
  224 Implement the scan method to read a deb file.
  225 
  226 =cut
  227 
  228 sub scan {
  229     my $this=shift;
  230     $this->SUPER::scan(@_);
  231     my $file=$this->filename;
  232 
  233     my @control=$this->getcontrolfile('control');
  234     die "Control file couldn't be read!"
  235         if @control == 0;
  236     # Parse control file and extract fields. Use a translation table
  237     # to map between the debian names and the internal field names,
  238     # which more closely resemble those used by rpm (for historical
  239     # reasons; TODO: change to deb style names).
  240     my $description='';
  241     my $field;
  242     my %fieldtrans=(
  243         Package => 'name',
  244         Version => 'version',
  245         Architecture => 'arch',
  246         Maintainer => 'maintainer',
  247         Section => 'group',
  248         Description => 'summary',
  249     );
  250     for (my $i=0; $i <= $#control; $i++) {
  251         $_ = $control[$i];
  252         chomp;
  253         if (/^(\w.*?):\s+(.*)/) {
  254             # Really old debs might have oddly capitalized
  255             # field names.
  256             $field=ucfirst(lc($1));
  257             if (exists $fieldtrans{$field}) {
  258                 $field=$fieldtrans{$field};
  259                 $this->$field($2);
  260             }
  261         }
  262         elsif (/^ / && $field eq 'summary') {
  263             # Handle extended description.
  264             s/^ //g;
  265             $_="" if $_ eq ".";
  266             $description.="$_\n";
  267         }
  268     }
  269     $this->description($description);
  270 
  271     $this->copyright("see /usr/share/doc/".$this->name."/copyright");
  272     $this->group("unknown") if ! $this->group;
  273     $this->distribution("Debian");
  274     $this->origformat("deb");
  275     $this->binary_info(scalar $this->getcontrolfile('control'));
  276 
  277     # Read in the list of conffiles, if any.
  278     my @conffiles;
  279     @conffiles=map { chomp; $_ } $this->getcontrolfile('conffiles');
  280     $this->conffiles(\@conffiles);
  281 
  282     # Read in the list of all files.
  283     # Note that tar doesn't supply a leading '/', so we have to add that.
  284     my $datamember_cmd;
  285     if ($this->have_dpkg_deb) {
  286         $datamember_cmd = "dpkg-deb --fsys-tarfile '$file'";
  287     }
  288     else {
  289         $datamember_cmd = $this->get_datamember_cmd($file);
  290     }
  291     my @filelist=map { chomp; s:\./::; "/$_" }
  292              $this->runpipe(0, "$datamember_cmd | tar tf -");
  293     $this->filelist(\@filelist);
  294 
  295     # Read in the scripts, if any.
  296     foreach my $field (qw{postinst postrm preinst prerm}) {
  297         $this->$field(scalar $this->getcontrolfile($field));
  298     }
  299 
  300     return 1;
  301 }
  302 
  303 =item unpack
  304 
  305 Implement the unpack method to unpack a deb file.
  306 
  307 =cut
  308 
  309 sub unpack {
  310     my $this=shift;
  311     $this->SUPER::unpack(@_);
  312     my $file=$this->filename;
  313 
  314     if ($this->have_dpkg_deb) {
  315         $this->do("dpkg-deb", "-x", $file, $this->unpacked_tree)
  316             or die "Unpacking of '$file' failed: $!";
  317     }
  318     else {
  319         my $datamember_cmd = $this->get_datamember_cmd($file);
  320 
  321         $this->do("$datamember_cmd | (cd ".$this->unpacked_tree."; tar xpf -)")
  322             or die "Unpacking of '$file' failed: $!";
  323     }
  324 
  325     return 1;
  326 }
  327 
  328 =item getpatch
  329 
  330 This method tries to find a patch file to use in the prep stage. If it
  331 finds one, it returns it. Pass in a list of directories to search for
  332 patches in.
  333 
  334 =cut
  335 
  336 sub getpatch {
  337     my $this=shift;
  338     my $anypatch=shift;
  339     
  340     my @patches;
  341     foreach my $dir (@_) {
  342         push @patches, glob("$dir/".$this->name."_".$this->version."-".$this->release."*.diff.gz");
  343     }
  344     if (! @patches) {
  345         # Try not matching the release, see if that helps.
  346         foreach my $dir (@_) {
  347             push @patches,glob("$dir/".$this->name."_".$this->version."*.diff.gz");
  348         }
  349         if (@patches && $anypatch) {
  350             # Fallback to anything that matches the name.
  351             foreach my $dir (@_) {
  352                 push @patches,glob("$dir/".$this->name."_*.diff.gz");
  353             }
  354         }
  355     }
  356 
  357     # If we ended up with multiple matches, return the first.
  358     return $patches[0];
  359 }
  360 
  361 =item prep
  362 
  363 Adds a populated debian directory the unpacked package tree, making it
  364 ready for building. This can either be done automatically, or via a patch
  365 file. 
  366 
  367 =cut
  368 
  369 sub prep {
  370     my $this=shift;
  371     my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
  372 
  373     $this->do("mkdir $dir/debian") ||
  374         die "mkdir $dir/debian failed: $!";
  375     
  376     # Use a patch file to debianize?
  377     if (defined $this->patchfile) {
  378         # The -f passed to zcat makes it pass uncompressed files
  379         # through without error.
  380         $this->do("zcat -f ".$this->patchfile." | (cd $dir; patch -p1)")
  381             or die "patch error: $!";
  382         # Look for .rej files.
  383         die "patch failed with .rej files; giving up"
  384             if $this->runpipe(1, "find '$dir' -name \"*.rej\"");
  385         $this->do('find', '.', '-name', '*.orig', '-exec', 'rm', '{}', ';');
  386         $this->do("chmod", 755, "$dir/debian/rules");
  387 
  388         # It's possible that the patch file changes the debian
  389         # release or version. Parse changelog to detect that.
  390         open (my $changelog, "<$dir/debian/changelog") || return;
  391         my $line=<$changelog>;
  392         if ($line=~/^[^ ]+\s+\(([^)]+)\)\s/) {
  393             my $version=$1;
  394             $version=~s/\s+//; # ensure no whitespace
  395             if ($version=~/(.*)-(.*)/) {
  396                 $version=$1;
  397                 $this->release($2);
  398             }
  399             $this->version($1);
  400         }
  401         close $changelog;
  402         
  403         return;
  404     }
  405 
  406     # Automatic debianization.
  407     # Changelog file.
  408     open (OUT, ">$dir/debian/changelog") || die "$dir/debian/changelog: $!";
  409     print OUT $this->name." (".$this->version."-".$this->release.") experimental; urgency=low\n";
  410     print OUT "\n";
  411     print OUT "  * Converted from .".$this->origformat." format to .deb by alien version $Alien::Version\n";
  412     print OUT "  \n";
  413     if (defined $this->changelogtext) {
  414         my $ct=$this->changelogtext;
  415         $ct=~s/^/  /gm;
  416         print OUT $ct."\n";
  417     }
  418     print OUT "\n";
  419     print OUT " -- ".$this->username." <".$this->email.">  ".$this->date."\n";
  420     close OUT;
  421 
  422     # Control file.
  423     open (OUT, ">$dir/debian/control") || die "$dir/debian/control: $!";
  424     print OUT "Source: ".$this->name."\n";
  425     print OUT "Section: alien\n";
  426     print OUT "Priority: extra\n";
  427     print OUT "Maintainer: ".$this->username." <".$this->email.">\n";
  428     print OUT "\n";
  429     print OUT "Package: ".$this->name."\n";
  430     print OUT "Architecture: ".$this->arch."\n";
  431     if (defined $this->depends) {
  432         print OUT "Depends: ".join(", ", "\${shlibs:Depends}", $this->depends)."\n";
  433     }
  434     else {
  435         print OUT "Depends: \${shlibs:Depends}\n";
  436     }
  437     print OUT "Description: ".$this->summary."\n";
  438     print OUT $this->description."\n";
  439     close OUT;
  440 
  441     # Copyright file.
  442     open (OUT, ">$dir/debian/copyright") || die "$dir/debian/copyright: $!";
  443     print OUT "This package was debianized by the alien program by converting\n";
  444     print OUT "a binary .".$this->origformat." package on ".$this->date."\n";
  445     print OUT "\n";
  446     print OUT "Copyright: ".$this->copyright."\n";
  447     print OUT "\n";
  448     print OUT "Information from the binary package:\n";
  449     print OUT $this->binary_info."\n";
  450     close OUT;
  451 
  452     # Conffiles, if any. Note that debhelper takes care of files in /etc.
  453     my @conffiles=grep { $_ !~ /^\/etc/ } @{$this->conffiles};
  454     if (@conffiles) {
  455         open (OUT, ">$dir/debian/conffiles") || die "$dir/debian/conffiles: $!";
  456         print OUT join("\n", @conffiles)."\n";
  457         close OUT;
  458     }
  459 
  460     # Use debhelper v7
  461     open (OUT, ">$dir/debian/compat") || die "$dir/debian/compat: $!";
  462     print OUT "7\n";
  463     close OUT;
  464 
  465     # A minimal rules file.
  466     open (OUT, ">$dir/debian/rules") || die "$dir/debian/rules: $!";
  467     my $fixpermscomment = $this->fixperms ? "" : "#";
  468     print OUT << "EOF";
  469 #!/usr/bin/make -f
  470 # debian/rules for alien
  471 
  472 PACKAGE=\$(shell dh_listpackages)
  473 
  474 build:
  475     dh_testdir
  476 
  477 clean:
  478     dh_testdir
  479     dh_testroot
  480     dh_clean -d
  481 
  482 binary-indep: build
  483 
  484 binary-arch: build
  485     dh_testdir
  486     dh_testroot
  487     dh_prep
  488     dh_installdirs
  489 
  490     dh_installdocs
  491     dh_installchangelogs
  492 
  493 # Copy the packages's files.
  494     find . -maxdepth 1 -mindepth 1 -not -name debian -print0 | \\
  495         xargs -0 -r -i cp -a {} debian/\$(PACKAGE)
  496 
  497 #
  498 # If you need to move files around in debian/\$(PACKAGE) or do some
  499 # binary patching, do it here
  500 #
  501 
  502 
  503 # This has been known to break on some wacky binaries.
  504 #   dh_strip
  505     dh_compress
  506 $fixpermscomment    dh_fixperms
  507     dh_makeshlibs
  508     dh_installdeb
  509     -dh_shlibdeps
  510     dh_gencontrol
  511     dh_md5sums
  512     dh_builddeb
  513 
  514 binary: binary-indep binary-arch
  515 .PHONY: build clean binary-indep binary-arch binary
  516 EOF
  517     close OUT;
  518     $this->do("chmod", 755, "$dir/debian/rules");
  519 
  520     if ($this->usescripts) {
  521         foreach my $script (qw{postinst postrm preinst prerm}) {
  522             $this->savescript($script, $this->$script());
  523         }
  524     }
  525     else {
  526         # There may be a postinst with permissions fixups even when
  527         # scripts are disabled.
  528         $this->savescript("postinst", undef);
  529     }
  530     
  531     my %dirtrans=( # Note: no trailing slashes on these directory names!
  532         # Move files to FHS-compliant locations, if possible.
  533         '/usr/man'  => '/usr/share/man',
  534         '/usr/info' => '/usr/share/info',
  535         '/usr/doc'  => '/usr/share/doc',
  536     );
  537     foreach my $olddir (keys %dirtrans) {
  538         if (-d "$dir/$olddir" && ! -e "$dir/$dirtrans{$olddir}") {
  539             # Ignore failure..
  540             my ($dirbase)=$dirtrans{$olddir}=~/(.*)\//;
  541             $this->do("install", "-d", "$dir/$dirbase");
  542             $this->do("mv", "$dir/$olddir", "$dir/$dirtrans{$olddir}");
  543             if (-d "$dir/$olddir") {
  544                 $this->do("rmdir", "-p", "$dir/$olddir");
  545             }
  546         }
  547         else {
  548             delete $dirtrans{$olddir};
  549         }
  550     }
  551     $this->dirtrans(\%dirtrans); # store for cleantree
  552 }
  553 
  554 =item build
  555 
  556 Build a deb.
  557 
  558 =cut
  559 
  560 sub build {
  561     my $this=shift;
  562     
  563     # Detect architecture mismatch and abort with a comprehensible
  564     # error message.
  565     my $arch=$this->arch;
  566     if ($arch ne 'all') {
  567         my $ret=system("dpkg-architecture", "-i".$arch);
  568         if ($ret != 0) {
  569             die $this->filename." is for architecture ".$this->arch." ; the package cannot be built on this system"."\n";
  570         }
  571     }
  572 
  573     chdir $this->unpacked_tree;
  574     my $log=$this->runpipe(1, "debian/rules binary 2>&1");
  575     chdir "..";
  576     my $err=$?;
  577     if ($err) {
  578         if (! defined $log) {
  579             die "Package build failed; could not run generated debian/rules file.\n";
  580         }
  581         die "Package build failed. Here's the log:\n", $log;
  582     }
  583 
  584     return $this->name."_".$this->version."-".$this->release."_".$this->arch.".deb";
  585 }
  586 
  587 =item cleantree
  588 
  589 Delete the entire debian/ directory.
  590 
  591 =cut
  592 
  593 sub cleantree {
  594         my $this=shift;
  595     my $dir=$this->unpacked_tree || die "The package must be unpacked first!";
  596 
  597     my %dirtrans=%{$this->dirtrans};
  598     foreach my $olddir (keys %dirtrans) {
  599         if (! -e "$dir/$olddir" && -d "$dir/$dirtrans{$olddir}") {
  600             # Ignore failure.. (should I?)
  601             my ($dirbase)=$dir=~/(.*)\//;
  602             $this->do("install", "-d", "$dir/$dirbase");
  603             $this->do("mv", "$dir/$dirtrans{$olddir}", "$dir/$olddir");
  604             if (-d "$dir/$dirtrans{$olddir}") {
  605                 $this->do("rmdir", "-p", "$dir/$dirtrans{$olddir}");
  606             }
  607         }
  608     }
  609     
  610     $this->do("rm", "-rf", "$dir/debian");
  611 }
  612 
  613 =item package
  614 
  615 Set/get package name. 
  616 
  617 Always returns the package name in lowercase with all invalid characters
  618 rmoved. The name is however, stored unchanged.
  619 
  620 =cut
  621 
  622 sub name {
  623     my $this=shift;
  624     
  625     # set
  626     $this->{name} = shift if @_;
  627     return unless defined wantarray; # optimization
  628     
  629     # get
  630     $_=lc($this->{name});
  631     tr/_/-/;
  632     s/[^a-z0-9-\.\+]//g;
  633     return $_;
  634 }
  635 
  636 =item version
  637 
  638 Set/get package version.
  639 
  640 When the version is set, it will be stripped of any epoch. If there is a
  641 release, the release will be stripped away and used to set the release
  642 field as a side effect. Otherwise, the release will be set to 1.
  643 
  644 More sanitization of the version is done when the field is retrieved, to
  645 make sure it is a valid debian version field.
  646 
  647 =cut
  648 
  649 sub version {
  650     my $this=shift;
  651 
  652     # set
  653     if (@_) {
  654         my $version=shift;
  655         if ($version =~ /(.+)-(.+)/) {
  656                     $version=$1;
  657                     $this->release($2);
  658             }
  659             else {
  660                     $this->release(1);
  661         }
  662             # Kill epochs.
  663         $version=~s/^\d+://;
  664         
  665         $this->{version}=$version;
  666         }
  667     
  668     # get
  669     return unless defined wantarray; # optimization
  670     $_=$this->{version};
  671     # Make sure the version contains a digit at the start, as required
  672     # by dpkg-deb.
  673     unless (/^[0-9]/) {
  674         $_="0".$_;
  675     }
  676     # filter out some characters not allowed in debian versions
  677     s/[^-.+~:A-Za-z0-9]//g; # see lib/dpkg/parsehelp.c parseversion
  678     return $_;
  679 }
  680 
  681 =item release
  682 
  683 Set/get package release.
  684 
  685 Always returns a sanitized release version. The release is however, stored
  686 unchanged.
  687 
  688 =cut
  689 
  690 sub release {
  691     my $this=shift;
  692 
  693     # set
  694     $this->{release} = shift if @_;
  695 
  696     # get
  697     return unless defined wantarray; # optimization
  698     $_=$this->{release};
  699     # Make sure the release contains digets.
  700     return $_."-1" unless /[0-9]/;
  701     return $_;
  702 }
  703 
  704 =item description
  705 
  706 Set/get description
  707 
  708 Although the description is stored internally unchanged, this will always
  709 return a sanitized form of it that is compliant with Debian standards.
  710 
  711 =cut
  712 
  713 sub description {
  714     my $this=shift;
  715 
  716     # set
  717     $this->{description} = shift if @_;
  718 
  719     # get
  720     return unless defined wantarray; # optimization
  721     my $ret='';
  722     foreach (split /\n/,$this->{description}) {
  723         s/\t/        /g; # change tabs to spaces
  724         s/\s+$//g; # remove trailing whitespace
  725         $_="." if $_ eq ''; # empty lines become dots
  726         $ret.=" $_\n";
  727     }
  728     $ret=~s/^\n+//g; # kill leading blank lines
  729     $ret.=" .\n" if length $ret;
  730     $ret.=" (Converted from a ".$this->origformat." package by alien version $Alien::Version.)";
  731     return $ret;
  732 }
  733 
  734 =item date
  735 
  736 Returns the date, in rfc822 format.
  737 
  738 =cut
  739 
  740 sub date {
  741     my $this=shift;
  742 
  743     my $date=$this->runpipe(1, "date -R");
  744     chomp $date;
  745     if (!$date) {
  746         die "date -R did not return a valid result.";
  747     }
  748 
  749     return $date;
  750 }
  751 
  752 =item email
  753 
  754 Returns an email address for the current user.
  755 
  756 =cut
  757 
  758 sub email {
  759     my $this=shift;
  760 
  761     return $ENV{EMAIL} if exists $ENV{EMAIL};
  762 
  763     my $login = getlogin || (getpwuid($<))[0] || $ENV{USER};
  764     my $mailname='';
  765     if (open (MAILNAME,"</etc/mailname")) {
  766         $mailname=<MAILNAME>;
  767         if (defined $mailname) {
  768             chomp $mailname;
  769         }
  770         close MAILNAME;
  771     }
  772     if (!$mailname) {
  773         $mailname=$this->runpipe(1, "hostname");
  774         chomp $mailname;
  775     }
  776     return "$login\@$mailname";
  777 }
  778 
  779 =item username
  780 
  781 Returns the user name of the real uid.
  782 
  783 =cut
  784 
  785 sub username {
  786     my $this=shift;
  787 
  788     my $username;
  789     my $login = getlogin || (getpwuid($<))[0] || $ENV{USER};
  790     (undef, undef, undef, undef, undef, undef, $username) = getpwnam($login);
  791 
  792     # Remove GECOS fields from username.
  793     $username=~s/,.*//g;
  794 
  795     # The ultimate fallback.
  796     if ($username eq '') {
  797         $username=$login;
  798     }
  799 
  800     return $username;
  801 }
  802 
  803 =item savescript
  804 
  805 Saves script to debian directory.
  806 
  807 =cut
  808 
  809 sub savescript {
  810     my $this=shift;
  811     my $script=shift;
  812     my $data=shift;
  813 
  814     if ($script eq 'postinst') {
  815         $data=$this->gen_postinst($data);
  816     }
  817 
  818     my $dir=$this->unpacked_tree;
  819 
  820     return unless defined $data;
  821     next if $data =~ m/^\s*$/;
  822     open (OUT,">$dir/debian/$script") ||
  823         die "$dir/debian/$script: $!";
  824     print OUT $data;
  825     close OUT;
  826 }
  827 
  828 =item gen_postinst
  829 
  830 Modifies or creates a postinst. This may include generated shell code to set
  831 owners and groups from the owninfo field, and update modes from the modeinfo
  832 field.
  833 
  834 =cut
  835 
  836 sub gen_postinst {
  837     my $this=shift;
  838     my $postinst=shift;
  839 
  840     my $owninfo = $this->owninfo;
  841     my $modeinfo = $this->modeinfo;
  842     return $postinst unless ref $owninfo && %$owninfo;
  843 
  844     # If there is no postinst, let's make one up..
  845     $postinst="#!/bin/sh\n" unless defined $postinst && length $postinst;
  846     
  847     my ($firstline, $rest)=split(/\n/, $postinst, 2);
  848     if ($firstline !~ m/^#!\s*\/bin\/(ba)?sh/) {
  849         print STDERR "warning: unable to add ownership fixup code to postinst as the postinst is not a shell script!\n";
  850         return $postinst;
  851     }
  852 
  853     my $permscript="# alien added permissions fixup code\n";
  854     foreach my $file (sort keys %$owninfo) {
  855         my $quotedfile=$file;
  856         $quotedfile=~s/'/'"'"'/g; # no single quotes in single quotes..
  857         $permscript.="chown '".$owninfo->{$file}."' '$quotedfile'\n";
  858         $permscript.="chmod '".$modeinfo->{$file}."' '$quotedfile'\n"
  859             if (defined $modeinfo->{$file});
  860     }
  861     return "$firstline\n$permscript\n$rest";
  862 }
  863 
  864 =back
  865 
  866 =head1 AUTHOR
  867 
  868 Joey Hess <joey@kitenet.net>
  869 
  870 =cut
  871 
  872 1