[Bps-public-commit] r16385 - Shipwright/branches/1.10/lib/Shipwright/Script

[sunnavy at bestpractical.com]

Author: sunnavy
Date: Mon Oct 20 03:45:57 2008
New Revision: 16385

Modified:
   Shipwright/branches/1.10/lib/Shipwright/Script/Delete.pm

Log:
merged 16384 to 1.1

Modified: Shipwright/branches/1.10/lib/Shipwright/Script/Delete.pm
==============================================================================
--- Shipwright/branches/1.10/lib/Shipwright/Script/Delete.pm	(original)
+++ Shipwright/branches/1.10/lib/Shipwright/Script/Delete.pm	Mon Oct 20 03:45:57 2008
@@ -4,28 +4,66 @@
 use warnings;
 use Carp;
 
-use base qw/App::CLI::Command Shipwright::Script/;
+use base qw/App::CLI::Command Class::Accessor::Fast Shipwright::Script/;
+__PACKAGE__->mk_accessors(qw/unreferenced check_only/);
 
 use Shipwright;
 use Shipwright::Util;
 
+sub options {
+    (
+        'unreferenced' => 'unreferenced',
+        'C|check-only' => 'check_only',
+    );
+}
+
 sub run {
     my $self = shift;
     my $name = shift;
 
-    confess "need name arg\n" unless $name;
+    unless ( $name || $self->unreferenced ) {
+        confess "need name arg or --unreferenced\n";
+    }
+
+    if ( $name && $self->unreferenced ) {
+        confess "please choose only one thing: a dist name or --unreferenced";
+    }
 
     my $shipwright = Shipwright->new( repository => $self->repository, );
-    my $map = $shipwright->backend->map || {};
-    if ( $map->{$name} ) {
+    my @names;
 
-        # it's a cpan module
-        $name = $map->{$name};
+    if ($name) {
+        my $map = $shipwright->backend->map;
+        if ( $map && $map->{$name} ) {
+
+            # it's a cpan module
+            $name = $map->{$name};
+        }
+        @names = $name;
     }
+    else {
 
-    $shipwright->backend->trim( name => $name );
+        # unreferenced dists except the last one
+        my $refs  = $shipwright->backend->refs;
+        my $order = $shipwright->backend->order;
+        if ($refs) {
+            for my $name ( keys %$refs ) {
+                next if $name eq $order->[-1];
+                push @names, $name unless $refs->{$name};
+            }
+        }
+    }
+
+    if ( $self->check_only ) {
+        print "dists to be deleted are: @names\n";
+    }
+    else {
+        for my $name (@names) {
+            $shipwright->backend->trim( name => $name );
+        }
+        print "deleted @names with success\n";
+    }
 
-    print "deleted $name with success\n";
 }
 
 1;
@@ -45,3 +83,5 @@
  -l [--log-level] LOGLEVEL      : specify the log level
                                   (info, debug, warn, error, or fatal)
  --log-file FILENAME            : specify the log file
+ --unreferenced                 : to delete all unreferenced dists except the last one
+ --check-only                   : check the lists, not really delete