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

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