git.maemo.org Git - maemian/blob - lib/Util.pm

   1 # Hey emacs! This is a -*- Perl -*- script!
   2 # Util -- Perl utility functions for lintian
   3
   4 # Copyright (C) 1998 Christian Schwarz
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, you can find it on the World Wide
  18 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  19 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  20 # MA 02110-1301, USA.
  21
  22 package Util;
  23 use strict;
  24
  25 use Exporter;
  26
  27 # Force export as soon as possible, since some of the modules we load also
  28 # depend on us and the sequencing can cause things not to be exported
  29 # otherwise.
  30 our (@ISA, @EXPORT);
  31 BEGIN {
  32     @ISA = qw(Exporter);
  33     @EXPORT = qw(parse_dpkg_control
  34         read_dpkg_control
  35         get_deb_info
  36         get_dsc_info
  37         slurp_entire_file
  38         get_file_checksum
  39         file_is_encoded_in_non_utf8
  40         fail
  41         system_env
  42         delete_dir
  43         copy_dir
  44         gunzip_file
  45         touch_file
  46         perm2oct);
  47 }
  48
  49 use FileHandle;
  50 use Maemian::Command qw(spawn);
  51 use Maemian::Output qw(string);
  52 use Digest::MD5;
  53
  54 # general function to read dpkg control files
  55 # this function can parse output of `dpkg-deb -f', .dsc,
  56 # and .changes files (and probably all similar formats)
  57 # arguments:
  58 #    $filehandle
  59 #    $debconf_flag (true if the file is a debconf template file)
  60 # output:
  61 #    list of hashes
  62 #    (a hash contains one sections,
  63 #    keys in hash are lower case letters of control fields)
  64 sub parse_dpkg_control {
  65     my ($CONTROL, $debconf_flag) = @_;
  66
  67     my @data;
  68     my $cur_section = 0;
  69     my $open_section = 0;
  70     my $last_tag;
  71
  72     local $_;
  73     while (<$CONTROL>) {
  74         chomp;
  75
  76         # FIXME: comment lines are only allowed in debian/control and should
  77         # be an error for other control files.
  78         next if /^\#/;
  79
  80         # empty line?
  81         if ((!$debconf_flag && m/^\s*$/) or ($debconf_flag && m/^$/)) {
  82             if ($open_section) { # end of current section
  83                 $cur_section++;
  84                 $open_section = 0;
  85             }
  86         }
  87         # pgp sig?
  88         elsif (m/^-----BEGIN PGP SIGNATURE/) { # skip until end of signature
  89             while (<$CONTROL>) {
  90                 last if m/^-----END PGP SIGNATURE/o;
  91             }
  92         }
  93         # other pgp control?
  94         elsif (m/^-----BEGIN PGP/) { # skip until the next blank line
  95             while (<$CONTROL>) {
  96                 last if /^\s*$/o;
  97             }
  98         }
  99         # new empty field?
 100         elsif (m/^(\S+):\s*$/o) {
 101             $open_section = 1;
 102
 103             my ($tag) = (lc $1);
 104             $data[$cur_section]->{$tag} = '';
 105
 106             $last_tag = $tag;
 107         }
 108         # new field?
 109         elsif (m/^(\S+):\s*(.*)$/o) {
 110             $open_section = 1;
 111
 112             # Policy: Horizontal whitespace (spaces and tabs) may occur
 113             # immediately before or after the value and is ignored there.
 114             my ($tag,$value) = (lc $1,$2);
 115             $value =~ s/\s+$//;
 116             $data[$cur_section]->{$tag} = $value;
 117
 118             $last_tag = $tag;
 119         }
 120         # continued field?
 121         elsif (m/^([ \t].*)$/o) {
 122             $open_section or fail("syntax error in section $cur_section after the tag $last_tag: $_");
 123
 124             # Policy: Many fields' values may span several lines; in this case
 125             # each continuation line must start with a space or a tab.  Any
 126             # trailing spaces or tabs at the end of individual lines of a
 127             # field value are ignored.
 128             my $value = $1;
 129             $value =~ s/\s+$//;
 130             $data[$cur_section]->{$last_tag} .= "\n" . $value;
 131         }
 132     }
 133
 134     return @data;
 135 }
 136
 137 sub read_dpkg_control {
 138     my ($file, $debconf_flag) = @_;
 139
 140     if (not _ensure_file_is_sane($file)) {
 141         return undef;
 142     }
 143
 144     open(my $CONTROL, '<', $file)
 145         or fail("cannot open control file $file for reading: $!");
 146     my @data = parse_dpkg_control($CONTROL, $debconf_flag);
 147     close($CONTROL)
 148         or fail("pipe for control file $file exited with status: $?");
 149     return @data;
 150 }
 151
 152 sub get_deb_info {
 153     my ($file) = @_;
 154
 155     if (not _ensure_file_is_sane($file)) {
 156         return undef;
 157     }
 158
 159     # `dpkg-deb -f $file' is very slow. Instead, we use ar and tar.
 160     my $opts = { pipe_out => FileHandle->new };
 161     spawn($opts,
 162           ['ar', 'p', $file, 'control.tar.gz'],
 163           '|', ['tar', '--wildcards', '-xzO', '-f', '-', '*control'])
 164         or fail("cannot fork to unpack $file: $opts->{exception}\n");
 165     my @data = parse_dpkg_control($opts->{pipe_out});
 166     $opts->{harness}->finish();
 167     return $data[0];
 168 }
 169
 170 sub get_dsc_info {
 171     my ($file) = @_;
 172
 173     if (not _ensure_file_is_sane($file)) {
 174         return undef;
 175     }
 176
 177     my @data = read_dpkg_control($file);
 178     return $data[0];
 179 }
 180
 181 sub _ensure_file_is_sane {
 182     my ($file) = @_;
 183
 184     # if file exists and is not 0 bytes
 185     if (-f $file and -s $file) {
 186         return 1;
 187     }
 188     return 0;
 189 }
 190
 191 sub slurp_entire_file {
 192     my $file = shift;
 193     open(C, '<', $file)
 194         or fail("cannot open file $file for reading: $!");
 195     local $/;
 196     local $_ = <C>;
 197     close(C);
 198     return $_;
 199 }
 200
 201 sub get_file_checksum {
 202         my ($alg, $file) = @_;
 203         open (FILE, '<', $file) or fail("Couldn't open $file");
 204         my $digest;
 205         if ($alg eq 'md5') {
 206             $digest = Digest::MD5->new;
 207         } elsif ($alg =~ /sha(\d+)/) {
 208             require Digest::SHA;
 209             $digest = Digest::SHA->new($1);
 210         }
 211         $digest->addfile(*FILE);
 212         close FILE or fail("Couldn't close $file");
 213         return $digest->hexdigest;
 214 }
 215
 216 sub file_is_encoded_in_non_utf8 {
 217         my ($file, $type, $pkg) = @_;
 218         my $non_utf8 = 0;
 219
 220         open (ICONV, '-|', "env LANG=C iconv -f utf8 -t utf8 $file 2>&1")
 221             or fail("failure while checking encoding of $file for $type package $pkg");
 222         my $line = 1;
 223         while (<ICONV>) {
 224                 if (m/iconv: illegal input sequence at position \d+$/) {
 225                         $non_utf8 = 1;
 226                         last;
 227                 }
 228                 $line++
 229         }
 230         close ICONV;
 231
 232         return $line if $non_utf8;
 233         return 0;
 234 }
 235
 236 # Just like system, except cleanses the environment first to avoid any strange
 237 # side effects due to the user's environment.
 238 sub system_env {
 239     my @whitelist = qw(PATH INTLTOOL_EXTRACT);
 240     my %newenv = map { exists $ENV{$_} ? ($_ => $ENV{$_}) : () } @whitelist;
 241     my $pid = fork;
 242     if (not defined $pid) {
 243         return -1;
 244     } elsif ($pid == 0) {
 245         %ENV = %newenv;
 246         exec @_ or die("exec of $_[0] failed: $!\n");
 247     } else {
 248         waitpid $pid, 0;
 249         return $?;
 250     }
 251 }
 252
 253 # Translate permission strings like `-rwxrwxrwx' into an octal number.
 254 sub perm2oct {
 255     my ($t) = @_;
 256
 257     my $o = 0;
 258
 259     $t =~ m/^.(.)(.)(.)(.)(.)(.)(.)(.)(.)/o;
 260
 261     $o += 00400 if $1 eq 'r';   # owner read
 262     $o += 00200 if $2 eq 'w';   # owner write
 263     $o += 00100 if $3 eq 'x';   # owner execute
 264     $o += 04000 if $3 eq 'S';   # setuid
 265     $o += 04100 if $3 eq 's';   # setuid + owner execute
 266     $o += 00040 if $4 eq 'r';   # group read
 267     $o += 00020 if $5 eq 'w';   # group write
 268     $o += 00010 if $6 eq 'x';   # group execute
 269     $o += 02000 if $6 eq 'S';   # setgid
 270     $o += 02010 if $6 eq 's';   # setgid + group execute
 271     $o += 00004 if $7 eq 'r';   # other read
 272     $o += 00002 if $8 eq 'w';   # other write
 273     $o += 00001 if $9 eq 'x';   # other execute
 274     $o += 01000 if $9 eq 'T';   # stickybit
 275     $o += 01001 if $9 eq 't';   # stickybit + other execute
 276
 277     return $o;
 278 }
 279
 280 sub delete_dir {
 281     return spawn(undef, ['rm', '-rf', '--', @_]);
 282 }
 283
 284 sub copy_dir {
 285     return spawn(undef, ['cp', '-a', '--', @_]);
 286 }
 287
 288 sub gunzip_file {
 289     my ($in, $out) = @_;
 290     spawn({out => $out, fail => 'error'},
 291           ['gzip', '-dc', $in]);
 292 }
 293
 294 # create an empty file
 295 # --okay, okay, this is not exactly what `touch' does :-)
 296 sub touch_file {
 297     open(T, '>', $_[0]) or return 0;
 298     close(T) or return 0;
 299
 300     return 1;
 301 }
 302
 303 sub fail {
 304     my $str;
 305     if (@_) {
 306         $str = string('internal error', @_);
 307     } elsif ($!) {
 308         $str = string('internal error', "$!");
 309     } else {
 310         $str = string('internal error');
 311     }
 312     $! = 2; # set return code outside eval()
 313     die $str;
 314 }
 315
 316 1;
 317
 318 # Local Variables:
 319 # indent-tabs-mode: t
 320 # cperl-indent-level: 4
 321 # End:
 322 # vim: syntax=perl sw=4 ts=8