--- apt-installed-status/trunk/apt-installed-status	2014/06/12 08:41:59	331
+++ apt-installed-status/trunk/apt-installed-status	2014/06/12 09:52:01	332
@@ -144,30 +144,63 @@
 # OUTPUT DATA #
 ###############
 
-sub print_orphans
-{
-  foreach my $package_data (values %installed_packages) {
-    foreach my $entry (@$package_data) {
+# Go through the list of all packages and call a subroutine on each installed
+# package.
+# Parameter 1: $sub: Reference to the subroutine to call
+#   Each call gets two parameters: the entry and $long
+# Parameter 2..: @params: All other parameters
+# Returns: Nothing
+# Side effects: Generates output on STDOUT
+sub iterate_through_packages {
+  my ($sub, @params) = @_;
+  foreach my $package_name (sort keys %installed_packages) {
+    foreach my $entry (@{$installed_packages{$package_name}}) {
       if ($entry->{status} eq 'install ok installed') {
-        if (! @{$entry->{lists}}) {
-          print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n";
-        }
+        &$sub($entry, @params)
       }
     }
   }
 }
 
-sub print_all
+# Print an entry, either with or without its archives
+# Parameter 1: $entry: a hash reference containing keys package, architecture
+#   and version (as well as lists if $long is true)
+# Parameter 2: $long: whether to print the archives too
+# Returns: nothing
+# Side effects: Generates output on STDOUT
+sub print_item 
+{
+  my ($entry, $long) = @_;
+  if ($long) { 
+    print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n";
+  } else {
+    print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n";
+  }
+}
+
+# Print all packages, including archives
+sub print_all 
 {
-  foreach my $package_name (sort keys %installed_packages) {
-    foreach my $entry (@{$installed_packages{$package_name}}) {
-      if ($entry->{status} eq 'install ok installed') {
-        print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n";
-      }
-    }
+  iterate_through_packages(\&print_item, 1);
+}
+
+
+# Print only those packages that have no archive associated with them
+sub print_orphans
+{
+  iterate_through_packages(\&print_orphans_item);
+}
+
+# Callback: check whether an entry is an orphan and if so print it
+sub print_orphans_item
+{
+  my ($entry) = @_;
+  if (! @{$entry->{lists}}) {
+    print_item($entry, 0);
   }
 }
 
+# Print those packages which are only in the specified archives
 sub print_archives_only
 {
   my ($archives,$long) = @_;
@@ -175,57 +208,101 @@
   foreach my $archive (split (/,/,$archives)) {
     $archives{$archive} = 1;
   }
-  foreach my $package_name (sort keys %installed_packages) {
-    foreach my $entry (@{$installed_packages{$package_name}}) {
-      if ($entry->{status} eq 'install ok installed') {
-        my $valid = 1;
-        my $nr=0;
-        foreach my $list (@{$entry->{lists}}) {
-          $nr++;
-          if (! exists($archives{$list})) {
-            $valid = 0;
-            last;
-          }
-        }
-        if ($valid and $nr) {
-          if ($long) { 
-            print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n";
-          } else {
-           print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n";
-          }
-        }
-      }
+  iterate_through_packages(\&print_archives_only_item, \%archives, $long);
+}
+
+# Callback: print an entry if it is only in the specified archives
+sub print_archives_only_item
+{
+  my ($entry,$archives, $long) = @_;
+  my $valid = 1;
+  foreach my $list (@{$entry->{lists}}) {
+    if (! exists($archives->{$list})) {
+      $valid = 0;
+      last;
     }
   }
+  if ($valid and @{$entry->{lists}}) {
+    print_item($entry, $long)
+  }
 }
 
+# Print those packages which are only in the archives specified through a 
+# regular expression
 sub print_archives_only_regexp
 {
   my ($archives_regexp,$long) = @_;
-  foreach my $package_name (sort keys %installed_packages) {
-    foreach my $entry (@{$installed_packages{$package_name}}) {
-      if ($entry->{status} eq 'install ok installed') {
-        my $valid = 1;
-        my $nr=0;
-        foreach my $list (@{$entry->{lists}}) {
-          $nr++;
-          if (! ($list =~ /$archives_regexp/)) {
-            $valid = 0;
-            last;
-          }
-        }
-        if ($valid and $nr) {
-          if ($long) {
-            print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\t".join(',',@{$entry->{lists}})."\n";
-          } else {
-            print $entry->{package}."\t".$entry->{architecture}."\t".$entry->{version}."\n";
-          }
-        }
-      }
+  iterate_through_packages(\&print_archives_only_regexp_item, $archives_regexp, $long);
+}
+
+# Callback: print an entry if it is only in the archives specified through a 
+# regular expression
+sub print_archives_only_regexp_item
+{
+  my ($entry, $archives_regexp, $long) = @_;
+  my $valid = 1;
+  foreach my $list (@{$entry->{lists}}) {
+    if (! ($list =~ /$archives_regexp/)) {
+      $valid = 0;
+      last;
     }
   }
+  if ($valid and @{$entry->{lists}}) {
+    print_item($entry, $long)
+  }
+}
+
+# Print those packages which are not in the specified archives
+sub print_archives_except
+{
+  my ($archives,$long) = @_;
+  my %archives;
+  foreach my $archive (split (/,/,$archives)) {
+    $archives{$archive} = 1;
+  }
+  iterate_through_packages(\&print_archives_except_item, \%archives, $long);
 }
 
+# Callback: print an entry if it is not in the specified archives
+sub print_archives_except_item
+{
+  my ($entry,$archives, $long) = @_;
+  my $valid = 1;
+  foreach my $list (@{$entry->{lists}}) {
+    if (exists($archives->{$list})) {
+      $valid = 0;
+      last;
+    }
+  }
+  if ($valid and @{$entry->{lists}}) {
+    print_item($entry, $long)
+  }
+}
+
+# Print those packages which are not in the archives specified through a 
+# regular expression
+sub print_archives_except_regexp
+{
+  my ($archives_regexp,$long) = @_;
+  iterate_through_packages(\&print_archives_except_regexp_item, $archives_regexp, $long);
+}
+
+# Callback: print an entry if it is not in the archives specified through a 
+# regular expression
+sub print_archives_except_regexp_item
+{
+  my ($entry, $archives_regexp, $long) = @_;
+  my $valid = 1;
+  foreach my $list (@{$entry->{lists}}) {
+    if ($list =~ /$archives_regexp/) {
+      $valid = 0;
+      last;
+    }
+  }
+  if ($valid and @{$entry->{lists}}) {
+    print_item($entry, $long)
+  }
+}
 
 #########################
 # COMMAND LINE HANDLING #
@@ -241,6 +318,10 @@
   print STDERR "        archives (seperated by commas)\n";
   print STDERR "  -A ARCHREGEXP: archives: list all packages that are only in archives\n";
   print STDERR "        that match the regular expression\n";
+  print STDERR "  -x ARCHS: except: list all packages that are not in one of the listed\n";
+  print STDERR "        archives (seperated by commas)\n";
+  print STDERR "  -X ARCHREGEXP: except: list all packages that are not in archives\n";
+  print STDERR "        that match the regular expression\n";
   print STDERR "  -l: long: print archives too\n";
 
   print STDERR "Default: print all packages and sources\n";
@@ -261,7 +342,7 @@
 
 our $VERSION=$version;
 my %options;
-if (! getopts('hVola:A:',\%options))
+if (! getopts('hVola:A:x:X:',\%options))
 {
   print_help();
   exit 1;
@@ -291,6 +372,14 @@
   print_archives_only_regexp($options{A},$long);
   exit 0;
 }
+if ($options{x}) {
+  print_archives_except($options{x},$long);
+  exit 0;
+}
+if ($options{X}) {
+  print_archives_except_regexp($options{X},$long);
+  exit 0;
+}
 print_all;