git.maemo.org Git - minimae/blob - minimae

   1 #!/usr/bin/perl
   2
   3 # Copyright (C) Jeremiah C. Foster 2009, based on:
   4 #   Lintian -- Debian package checker
   5 # Copyright (C) 1998 Christian Schwarz and Richard Braakman
   6
   7 =head1 NAME
   8
   9 minimae - Executes some tests on a gzipped tarball, looking for
  10 debian packaging files and conventions. minimae gets a json string
  11 as input and parses that string to do its checks and find resources.
  12
  13 =cut
  14
  15 =head1 VERSION
  16
  17 This document describes minimae version 2.0
  18
  19 =head1 PURPOSE
  20
  21 Maemian is the maemo version of lintian - a policy checker designed to
  22 assure the quality of a package uploaded into the maemo.org repositories.
  23 The goal of maemian is to improve quality by checking that the maemo
  24 packaging policy is followed. In order to do that it reads files in the
  25 tarball that has been uploaded to the maemo repositories.
  26
  27 =head1 SYNOPSIS
  28
  29     # Check tarball
  30     minimae -i file.deb
  31
  32 =cut
  33
  34 use strict;
  35 use warnings;
  36 use Test::More tests => 8;
  37 use IPC::System::Simple qw/ capture /;
  38 use feature ":5.10";
  39 use Control;
  40 use Archive::Tar;
  41 use Perl6::Slurp;
  42 use RepoUtils;
  43 use File::Basename;
  44 use Parson;
  45
  46 # find our tarball
  47 my $json_object = Parson->new();              # parse json file
  48 my $dsc = $json_object->parse_json();
  49
  50
  51 my $tarball = $ARGV[0];                       # Orignal tarball
  52 my $repo = RepoUtils->new();
  53 $repo->copy_file($tarball, "lab/");           # copy the tarball to the lab
  54 my $package_name = basename $tarball;
  55
  56 my $tar = Archive::Tar->new;
  57 $tar->read("lab/$package_name",1);
  58 if ($package_name =~ /orig.tar.gz/) {
  59   $package_name =~ s/.orig.tar.gz$//;         # Remove suffixes
  60 }
  61 else {
  62   $package_name =~ s/.tar.gz$//;              # Remove suffixes
  63 }
  64 $package_name =~ tr/_/-/;                     # translate underscore into dash
  65 $package_name =~ s/-[\d]$//;                  # trim package version
  66 $package_name =~ s/-.?maemo.$//;              # trim maemo version
  67 chdir("lab/");                                # We're in /lab now!
  68 $tar->extract();                              # extracted tarball now in lab/
  69
  70 my $changelog_file = "$package_name/debian/changelog";
  71 my $copyright_file = "$package_name/debian/copyright";
  72 my $control_file = "$package_name/debian/control";
  73
  74 # Check control file
  75 my $file_type = capture("file -i $control_file");
  76 ok(($file_type), "File type defined.");
  77 my ($name, $content, $charset) = split / /, $file_type;
  78 chomp($charset);
  79 given($charset) {
  80   when ("charset=us-ascii") {
  81     ok($charset, 'charset is ASCII.');
  82   }
  83   when ("charset=utf-8") {
  84     ok($charset, 'charset is UTF-8');
  85   }
  86   default {
  87     not_ok($charset, "$charset");
  88     die qq(Unknown charset for $charset.);
  89   }
  90 }
  91
  92 # Each chunk is a discreet package
  93 my @chunks = slurp $control_file, {irs => qr/\n\n/xms};
  94 print map { $_ . "\n" } @chunks;
  95
  96
  97 my @fields = slurp $control_file, {irs => qr/\n\n/xms};
  98 diag((grep /XB-Maemo-Icon/, split /\n/, $fields[-1]), ' Found icon in control file.');
  99 my @arches = grep /Architecture/, split /\n/, $fields[-1];
 100
 101 ok((grep /Architecture/, split /\n/, $fields[-1]), "Arches: $arches[-1]");
 102 ok((grep /XSBC/, @fields), 'Maemo specific maintainer field');
 103 my $package = grep /Package:/, split /\n/, $fields[-1];
 104 ok($package !~ /[M|m]aemo/, 'No potential copyright clash with maemo name');
 105
 106 # Check copyright file
 107 ok(-s $copyright_file, 'Copyright file exists and is non-empty');
 108 @fields = slurp $copyright_file, {irs => qr/\n\n/xms};
 109 my ($file_name, $type) = split / /, capture("file -i $copyright_file");
 110 ok($file_type !~ /application\/x-gzip/, 'Copyright not compressed.');
 111 my @copylines = map { $_ } grep /copyright|\(C\)/, @fields;
 112 ok((scalar @copylines > 1), 'Found copyright assignment.');
 113
 114 # check changelog
 115
 116
 117
 118 1;  # Nothing to see here, move along.
 119