[Rt-commit] r5409 - in rt/branches/3.7-EXPERIMENTAL: . html/Admin/Tools/Shredder html/Admin/Tools/Shredder/Elements html/Admin/Tools/Shredder/Elements/Error html/Admin/Tools/Shredder/Elements/Object lib/RT lib/RT/Shredder lib/RT/Shredder/Plugin sbin

ruz at bestpractical.com ruz at bestpractical.com
Mon Jun 19 22:10:00 EDT 2006


Author: ruz
Date: Mon Jun 19 22:09:49 2006
New Revision: 5409

Added:
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Error/
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Error/NoRights
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Error/NoStorage
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--Attachment
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--Ticket
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--User
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/ObjectCheckBox
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/PluginArguments
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/PluginHelp
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/SelectObjects
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/SelectPlugin
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/autohandler
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/index.html
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ACE.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Attachment.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CachedGroupMember.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Constants.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CustomField.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CustomFieldValue.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Dependencies.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Dependency.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Exceptions.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Group.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/GroupMember.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Link.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ObjectCustomFieldValue.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/POD.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Attachments.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Base.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Objects.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Tickets.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Users.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Principal.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Queue.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Record.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Scrip.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ScripAction.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ScripCondition.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Template.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Ticket.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Transaction.pm
   rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/User.pm
   rt/branches/3.7-EXPERIMENTAL/sbin/rt-shredder.in   (contents, props changed)
   rt/branches/3.7-EXPERIMENTAL/sbin/rt-validator.in   (contents, props changed)
Modified:
   rt/branches/3.7-EXPERIMENTAL/   (props changed)
   rt/branches/3.7-EXPERIMENTAL/configure.ac
   rt/branches/3.7-EXPERIMENTAL/html/Admin/Elements/ToolTabs

Log:


Modified: rt/branches/3.7-EXPERIMENTAL/configure.ac
==============================================================================
--- rt/branches/3.7-EXPERIMENTAL/configure.ac	(original)
+++ rt/branches/3.7-EXPERIMENTAL/configure.ac	Mon Jun 19 22:09:49 2006
@@ -295,6 +295,8 @@
 		 sbin/rt-setup-database
 		 sbin/rt-test-dependencies
          sbin/rt-clean-sessions
+         sbin/rt-shredder
+         sbin/rt-validator
  		 bin/mason_handler.fcgi
  		 bin/mason_handler.scgi
  		 bin/standalone_httpd

Modified: rt/branches/3.7-EXPERIMENTAL/html/Admin/Elements/ToolTabs
==============================================================================
--- rt/branches/3.7-EXPERIMENTAL/html/Admin/Elements/ToolTabs	(original)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Elements/ToolTabs	Mon Jun 19 22:09:49 2006
@@ -43,32 +43,34 @@
 %# those contributions and any derivatives thereof.
 %# 
 %# END BPS TAGGED BLOCK }}}
-<& /Admin/Elements/Tabs, subtabs => $tabs, 
-    current_tab => 'Admin/Tools/', 
-    current_subtab => $current_tab, 
-    Title => $Title &>
+<& /Admin/Elements/Tabs,
+    Title          => $Title,
+    current_tab    => 'Admin/Tools/',
+    subtabs        => $tabs,
+    current_subtab => $current_tab,
+&>
 
 <%INIT>
-  my $tabs = {
-                
-               A => { title => loc('System Configuration'),
-                           path => 'Admin/Tools/Configuration.html',
-                      }
+    my $tabs = {
+        A => { title => loc('System Configuration'),
+               path => 'Admin/Tools/Configuration.html',
+        },
+        E => { title => loc('Shredder'),
+               path  => 'Admin/Tools/Shredder',
+        },
+    };
 
-};
+    # Now let callbacks add their extra tabs
+    $m->comp('/Elements/Callback', %ARGS, tabs => $tabs);
 
-  # Now let callbacks add their extra tabs
-  $m->comp('/Elements/Callback', tabs => $tabs, %ARGS);
+    foreach my $tab ( values %{$tabs} ) {
+        next unless $tab->{'path'} eq $current_tab;
 
-  foreach my $tab (sort keys %{$tabs}) {
-    if ($tabs->{$tab}->{'path'} eq $current_tab) {
-      $tabs->{$tab}->{"subtabs"} = $subtabs;
-      $tabs->{$tab}->{"current_subtab"} = $current_subtab;
+        $tab->{"subtabs"} = $subtabs;
+        $tab->{"current_subtab"} = $current_subtab;
     }
-  }
 </%INIT>
 
-  
 <%ARGS>
 $id => undef
 $current_tab => undef

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Error/NoRights
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Error/NoRights	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,10 @@
+<& /Admin/Elements/Header, Title => 'Error' &>
+<& /Admin/Elements/ToolTabs,
+	current_tab => 'Admin/Tools/Shredder',
+	current_subtab => 'Admin/Tools/Shredder',
+	Title => 'Error',
+&>
+<div class="error">
+You don't have <b>SuperUser</b> right.
+</div>
+

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Error/NoStorage
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Error/NoStorage	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,14 @@
+<%ARGS>
+$Path => ''
+</%ARGS>
+<& /Admin/Elements/Header, Title => 'Error' &>
+<& /Admin/Elements/ToolTabs,
+	current_tab => 'Admin/Tools/Shredder',
+	current_subtab => 'Admin/Tools/Shredder',
+	Title => 'Error',
+&>
+<div class="error">
+RTx-Shredder extension needs directory to write dumps there.
+Please, check that you have <span class="file-path"><% $Path %></span> and
+it's writable for your web server.
+</div>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--Attachment
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--Attachment	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,6 @@
+<%ARGS>
+$Object => undef
+</%ARGS>
+<a href="<% $RT::WebBaseURL %>/Ticket/Attachment/<% $Object->TransactionId %>/<% $Object->id %>/">
+Attachment(id:<% $Object->id %>, FileName: <% $Object->Filename || '(no value)' %>)
+</a>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--Ticket
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--Ticket	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,6 @@
+<%ARGS>
+$Object => undef
+</%ARGS>
+<a href="<% $RT::WebBaseURL %>/Ticket/Display.html?id=<% $Object->id %>">
+Ticket(id:<% $Object->id %>, Subject: <% substr($Object->Subject, 0, 30) %>...)
+</a>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--User
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/Object/RT--User	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,6 @@
+<%ARGS>
+$Object => undef
+</%ARGS>
+<a href="<% $RT::WebBaseURL %>/Admin/Users/Modify.html?id=<% $Object->id %>">
+User(id:<% $Object->id %>, Name: <% $Object->Name %>)
+</a>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/ObjectCheckBox
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/ObjectCheckBox	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,19 @@
+<%ARGS>
+$Object => undef
+</%ARGS>
+<input type="checkbox" name="WipeoutObject" value="<% $Object->_AsString %>" />
+<span>
+% if( $m->comp_exists( $path ) ) {
+% $m->comp( $path, Object => $Object );
+% } else {
+<% $Object->_AsString %>
+% }
+</span><br />
+<%ONCE>
+require File::Spec;
+</%ONCE>
+<%INIT>
+my $path = ref $Object;
+$path =~ s/:/-/g;
+$path = File::Spec->catfile( 'Object', $path );
+</%INIT>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/PluginArguments
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/PluginArguments	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,15 @@
+<%ARGS>
+$Plugin => ''
+</%ARGS>
+<div id="shredder-plugin-<% $Plugin %>-arguments" class="shredder-form">
+<span>Fill arguments:</span><br />
+% foreach my $a( $plugin_obj->SupportArgs ) {
+<span><% $a %>:<span><input type="text" name="<% "$Plugin:$a" %>" value="<% $ARGS{ "$Plugin:$a" } || '' %>" /><br />
+% }
+</div>
+<%INIT>
+use RT::Shredder::Plugin;
+my $plugin_obj = new RT::Shredder::Plugin;
+my ($status, $msg) = $plugin_obj->LoadByName( $Plugin );
+die $msg unless $status;
+</%INIT>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/PluginHelp
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/PluginHelp	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,24 @@
+<%ARGS>
+$Plugin => ''
+</%ARGS>
+<div id="shredder-plugin-<% $Plugin %>-help" class="shredder-help">
+<% $text |n%>
+</div>
+<%ONCE>
+use RT::Shredder::Plugin;
+my $plugin_obj = new RT::Shredder::Plugin;
+my %plugins = $plugin_obj->List;
+</%ONCE>
+<%INIT>
+my $file = $plugins{ $Plugin };
+unless( $file ) {
+	$RT::Logger->error( "Couldn't find plugin '$Plugin'" );
+	return;
+}
+
+use RT::Shredder::POD qw();
+my $text = '';
+open my $io_handle, ">:scalar", \$text or die "Can't open scalar for write: $!";
+RT::Shredder::POD::plugin_html( $file, $io_handle );
+close $io_handle;
+</%INIT>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/SelectObjects
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/SelectObjects	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,20 @@
+<%ARGS>
+ at Objects => ()
+</%ARGS>
+<div id="shredder-plugin-results">
+% unless( @Objects ) {
+<& /Elements/ListActions, actions => ["Objects list is empty"] &>
+% } else {
+<div class="shredder-form">
+<input id="shredder-select-all-objects-checkbox" type="checkbox" name="SelectAllObjects" onclick="checkAllObjects()" />
+<span>click to check/uncheck all objects at once</span>
+<hr>
+% foreach my $o( @Objects ) {
+<& ObjectCheckBox, Object => $o &>
+% }
+</div>
+<& /Elements/Submit, Name => 'Wipeout', Label => loc('Wipeout') &>
+% }
+</div>
+<%INIT>
+</%INIT>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/SelectPlugin
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/Elements/SelectPlugin	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,27 @@
+<%ARGS>
+$Plugin => ''
+</%ARGS>
+<& PluginHelp, %ARGS, Plugin => 'Base' &>
+<div class="shredder-form">
+<span>Select plugin: </span>
+<select name="Plugin" onchange="showShredderPluginTab(this.value);">
+<option value="">(no value)</option>
+% foreach my $p( keys %plugins ) {
+<option value="<% $p %>" <% ($p eq $Plugin)? 'selected': '' %>><% $p %></option>
+% }
+</select>
+</div>
+<div id="shredder-plugin-tabs">
+% foreach my $p( keys %plugins ) {
+<div id="shredder-plugin-<% $p %>-tab" class="<% ($p ne $Plugin)? 'hidden': '' %>">
+<& PluginHelp, %ARGS, Plugin => $p &>
+<& PluginArguments, %ARGS, Plugin => $p &>
+</div>
+% }
+</div>
+<%INIT>
+use RT::Shredder::Plugin;
+my $plugin_obj = new RT::Shredder::Plugin;
+my %plugins = $plugin_obj->List;
+delete $plugins{'Base'};
+</%INIT>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/autohandler
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/autohandler	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,13 @@
+<%INIT>
+unless( $session{'CurrentUser'}->HasRight( Right => 'SuperUser', Object => $RT::System ) ) {
+	return $m->comp( 'Elements/Error/NoRights' );
+}
+
+use RT::Shredder ();
+my $path = RT::Shredder->StoragePath;
+unless( -d $path && -w _ ) {
+	return $m->comp( 'Elements/Error/NoStorage', Path => $path );
+}
+
+$m->call_next(%ARGS);
+</%INIT>

Added: rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/index.html
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/html/Admin/Tools/Shredder/index.html	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,115 @@
+<%ARGS>
+$Plugin => ''
+$Search => ''
+$Wipeout => ''
+ at WipeoutObject => ()
+</%ARGS>
+<& /Admin/Elements/Header, Title => $title &>
+<& /Admin/Elements/ToolTabs,
+	current_tab => 'Admin/Tools/Shredder',
+	current_subtab => 'Admin/Tools/Shredder',
+	Title => $title,
+&>
+<form id="shredder-search-form" action="<% $RT::WebPath %>/Admin/Tools/Shredder/" method="GET">
+<div id="shredder-select-plugin">
+<& /Elements/ListActions, actions => $messages{'Errors'} &>
+<& /Elements/ListActions, actions => $messages{'Success'} &>
+<& Elements/SelectPlugin, Plugin => $Plugin, %ARGS &>
+<div id="shredder-submit-button" class="<% $Plugin? '': 'hidden' %>">
+<& /Elements/Submit, Name => 'Search', Label => loc('Search') &>
+</div>
+</div>
+<br />
+% if( $Search || $Wipeout ) {
+<& Elements/SelectObjects, Objects => \@objs &>
+% }
+</form>
+<%INIT>
+
+require RT::Shredder;
+my $title = loc('Shredder');
+my %messages = ( Errors => [], Success => [] );
+my ($plugin_obj, @objs);
+
+my $catch_non_fatals = sub {
+    require RT::Shredder::Exceptions;
+    die $@ unless my $e = RT::Shredder::Exception::Info->caught;
+
+    push @{ $messages{Errors} }, "$e";
+    $Search = ''; @objs = ();
+    return 1;
+};
+
+
+if( $Plugin ) { { # use additional block({}) to effectively exit block on errors
+	use RT::Shredder::Plugin;
+	$plugin_obj = new RT::Shredder::Plugin;
+	my( $status, $msg ) = $plugin_obj->LoadByName( $Plugin );
+	unless( $status ) {
+		push @{ $messages{Errors} }, $msg;
+		$Search = '';
+		last;
+	}
+
+	my %args;
+	foreach my $k( keys %ARGS ) {
+		next unless $k =~ /^\Q$Plugin\E:(.*)$/;
+		$args{ $1 } = $ARGS{$k};
+	}
+	( $status, $msg ) = $plugin_obj->HasSupportForArgs( keys %args );
+	unless( $status ) {
+		push @{ $messages{Errors} }, $msg;
+		$Search = '';
+		last;
+	}
+
+	($status, $msg) = eval { $plugin_obj->TestArgs( %args ) };
+    $catch_non_fatals->() && last if $@;
+	unless( $status ) {
+		push @{ $messages{Errors} }, $msg;
+		$Search = '';
+		last;
+	}
+} }
+
+if( $Plugin && $Wipeout ) { { # use additional block({}) to effectively exit block on errors
+	my $shredder = new RT::Shredder( force => 1 );
+	my ($fn, $fh) = $shredder->SetFile;
+    push @{ $messages{'Success'} }, "SQL dump file is '$fn'";
+
+	$shredder->PutObjects( Objects => \@WipeoutObject );
+	my ($status, $msg) = $plugin_obj->SetResolvers( Shredder => $shredder );
+	unless( $status ) {
+		push @{ $messages{Errors} }, $msg;
+		$Search = ''; @objs = ();
+		last;
+	}
+	eval { $shredder->WipeoutAll };
+    $catch_non_fatals->() && last if $@;
+
+	push @{ $messages{Success} }, 'objects were successfuly removed';
+} }
+
+if( $Plugin && ( $Search || $Wipeout ) ) { { # use additional block({}) to effectively exit block on errors
+	my $status;
+	($status, @objs) = eval { $plugin_obj->Run };
+    $catch_non_fatals->() && last if $@;
+    unless( $status ) {
+		push @{ $messages{Errors} }, $objs[0];
+		$Search = ''; @objs = ();
+		last;
+	}
+	push @{ $messages{Success} }, 'executed plugin successfuly';
+
+	my $shredder = new RT::Shredder;
+	foreach my $o( splice @objs ) {
+		eval { push @objs, $shredder->CastObjectsToRecords( Objects => $o ) };
+        $catch_non_fatals->() && last if $@;
+	}
+	unless( @objs ) {
+		push @{ $messages{Success} }, 'plugin returned empty list';
+	} else {
+		push @{ $messages{Success} }, 'see object list below';
+	}
+} }
+</%INIT>

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,695 @@
+package RT::Shredder;
+use strict;
+use warnings;
+
+=head1 NAME
+
+RT::Shredder - Cleanup RT database
+
+=head1 SYNOPSIS
+
+=head2 CLI
+
+  rtx-shredder --force --plugin 'Tickets=queue,general;status,deleted'
+
+=head2 API
+
+Same action as in CLI example, but from perl script:
+
+  use RT::Shredder;
+  RT::Shredder::Init( force => 1 );
+  my $deleted = RT::Tickets->new( $RT::SystemUser );
+  $deleted->{'allow_deleted_search'} = 1;
+  $deleted->LimitQueue( VALUE => 'general' );
+  $deleted->LimitStatus( VALUE => 'deleted' );
+  while( my $t = $deleted->Next ) {
+      $t->Wipeout;
+  }
+
+=head1 DESCRIPTION
+
+RT::Shredder is extention to RT API which allow you to delete data
+from RT database. Now Shredder support wipe out of almost all RT objects
+ (Tickets, Transactions, Attachments, Users...)
+
+=head2 Command line tools(CLI)
+
+L<rtx-shredder> script that is shipped with the distribution allow
+you to delete objects from command line or with system tasks
+scheduler(cron or other).
+
+=head2 Web based interface(WebUI)
+
+Shredder's WebUI integrates into RT's WebUI and you can find it
+under Configuration->Tools->Shredder tab. This interface is similar
+to CLI and give you the same functionality, but it's available
+from browser.
+
+=head2 API
+
+L<RT::Shredder> modules is extension to RT API which add(push) methods
+into base RT classes. API is not well documented yet, but you can find
+usage examples in L<rtx-shredder> script code and in F<t/*> files.
+
+=head1 CONFIGURATION
+
+=head2 $RT::DependenciesLimit
+
+Shredder stops with error if object has more then C<$RT::DependenciesLimit>
+dependencies. By default this value is 1000. For example: ticket has 1000
+transactions or transaction has 1000 attachments. This is protection
+from bugs in shredder code, but sometimes when you have big mail loops
+you may hit it. You can change default value, in
+F<RT_SiteConfig.pm> add C<Set( $DependenciesLimit, new_limit );>
+
+=head2 $RT::ShredderStoragePath
+
+By default shredder saves dumps in F</path-to-RT-var-dir/data/RTx-Shredder>,
+with this option you can change path, but B<note> that value should be absolute
+path to the dir you want.
+
+=head1 API DESCRIPTION
+
+L<RT::Shredder> class implements interfaces to objects cache, actions
+on the objects in the cache and backups storage.
+
+=head2 Dependencies
+
+=cut
+
+our $VERSION = '0.04';
+use File::Spec ();
+
+
+BEGIN {
+# I can't use 'use lib' here since it breakes tests
+# because test suite uses old RT::Shredder setup from
+# RT lib path
+
+### after:     push @INC, qw(@RT_LIB_PATH@);
+    push @INC, qw(/opt/rt3/local/lib /opt/rt3/lib);
+    use RT::Shredder::Constants;
+    use RT::Shredder::Exceptions;
+
+    require RT;
+
+    require RT::Shredder::Record;
+
+    require RT::Shredder::ACE;
+    require RT::Shredder::Attachment;
+    require RT::Shredder::CachedGroupMember;
+    require RT::Shredder::CustomField;
+    require RT::Shredder::CustomFieldValue;
+    require RT::Shredder::GroupMember;
+    require RT::Shredder::Group;
+    require RT::Shredder::Link;
+    require RT::Shredder::Principal;
+    require RT::Shredder::Queue;
+    require RT::Shredder::Scrip;
+    require RT::Shredder::ScripAction;
+    require RT::Shredder::ScripCondition;
+    require RT::Shredder::Template;
+    require RT::Shredder::ObjectCustomFieldValue;
+    require RT::Shredder::Ticket;
+    require RT::Shredder::Transaction;
+    require RT::Shredder::User;
+}
+
+our @SUPPORTED_OBJECTS = qw(
+    ACE
+    Attachment
+    CachedGroupMember
+    CustomField
+    CustomFieldValue
+    GroupMember
+    Group
+    Link
+    Principal
+    Queue
+    Scrip
+    ScripAction
+    ScripCondition
+    Template
+    ObjectCustomFieldValue
+    Ticket
+    Transaction
+    User
+);
+
+=head2 GENERIC
+
+=head3 Init( %options )
+
+Sets shredder defaults, loads RT config and init RT interface.
+
+B<NOTE> that this is function and must be called with C<RT::Shredder::Init();>.
+
+B<TODO:> describe possible shredder options.
+
+=cut
+
+our %opt = ();
+
+sub Init
+{
+    %opt = @_;
+    RT::LoadConfig();
+    RT::Init();
+}
+
+=head3 new( %options )
+
+Shredder object constructor takes options hash and returns new object.
+
+=cut
+
+sub new
+{
+    my $proto = shift;
+    my $self = bless( {}, ref $proto || $proto );
+    $self->_Init( @_ );
+    return $self;
+}
+
+sub _Init
+{
+    my $self = shift;
+    $self->{'opt'} = { %opt, @_ };
+    $self->{'cache'} = {};
+    $self->{'resolver'} = {};
+}
+
+=head3 CastObjectsToRecords( Objects => undef )
+
+Cast objects to the C<RT::Record> objects or its ancesstors.
+Objects can be passed as SCALAR (format C<< <class>-<id> >>),
+ARRAY, C<RT::Record> ancesstors or C<RT::SearchBuilder> ancesstor.
+
+Most methods that takes C<Objects> argument use this method to
+cast argument value to list of records.
+
+Returns array of the records.
+
+For example:
+
+    my @objs = $shredder->CastObjectsToRecords(
+        Objects => [             # ARRAY reference
+            'RT::Attachment-10', # SCALAR or SCALAR reference
+            $tickets,            # RT::Tickets object (isa RT::SearchBuilder)
+            $user,               # RT::User object (isa RT::Record)
+        ],
+    );
+
+=cut
+
+sub CastObjectsToRecords
+{
+    my $self = shift;
+    my %args = ( Objects => undef, @_ );
+
+    my @res;
+    my $targets = delete $args{'Objects'};
+    unless( $targets ) {
+        RT::Shredder::Exception->throw( "Undefined Objects argument" );
+    }
+
+    if( UNIVERSAL::isa( $targets, 'RT::SearchBuilder' ) ) {
+        #XXX: try to use ->_DoSearch + ->ItemsArrayRef in feature
+        #     like we do in Record with links, but change only when
+        #     more tests would be available
+        while( my $tmp = $targets->Next ) { push @res, $tmp };
+    } elsif ( UNIVERSAL::isa( $targets, 'RT::Record' ) ) {
+        push @res, $targets;
+    } elsif ( UNIVERSAL::isa( $targets, 'ARRAY' ) ) {
+        foreach( @$targets ) {
+            push @res, $self->CastObjectsToRecords( Objects => $_ );
+        }
+    } elsif ( UNIVERSAL::isa( $targets, 'SCALAR' ) || !ref $targets ) {
+        $targets = $$targets if ref $targets;
+        my ($class, $id) = split /-/, $targets;
+        $class = 'RT::'. $class unless $class =~ /^RTx?::/i;
+        eval "require $class";
+        die "Couldn't load '$class' module" if $@;
+        my $obj = $class->new( $RT::SystemUser );
+        die "Couldn't construct new '$class' object" unless $obj;
+        $obj->Load( $id );
+        unless ( $obj->id ) {
+            $RT::Logger->error( "Couldn't load '$class' object with id '$id'" );
+            RT::Shredder::Exception::Info->throw( 'CouldntLoadObject' );
+        }
+        die "Loaded object has different id" unless( $id eq $obj->id );
+        push @res, $obj;
+    } else {
+        RT::Shredder::Exception->throw( "Unsupported type ". ref $targets );
+    }
+    return @res;
+}
+
+=head2 OBJECTS CACHE
+
+=head3 PutObjects( Objects => undef )
+
+Puts objects into cache.
+
+Returns array of the cache entries.
+
+See C<CastObjectsToRecords> method for supported types of the C<Objects>
+argument.
+
+=cut
+
+sub PutObjects
+{
+    my $self = shift;
+    my %args = ( Objects => undef, @_ );
+
+    my @res;
+    for( $self->CastObjectsToRecords( Objects => delete $args{'Objects'} ) ) {
+        push @res, $self->PutObject( %args, Object => $_ )
+    }
+
+    return @res;
+}
+
+=head3 PutObject( Object => undef )
+
+Puts record object into cache and returns its cache entry.
+
+B<NOTE> that this method support B<only C<RT::Record> object or its ancesstor
+objects>, if you want put mutliple objects or objects represented by different
+classes then use C<PutObjects> method instead.
+
+=cut
+
+sub PutObject
+{
+    my $self = shift;
+    my %args = ( Object => undef, @_ );
+
+    my $obj = $args{'Object'};
+    unless( UNIVERSAL::isa( $obj, 'RT::Record' ) ) {
+        RT::Shredder::Exception->throw( "Unsupported type '". (ref $obj || $obj || '(undef)')."'" );
+    }
+
+    my $str = $obj->_AsString;
+    return ($self->{'cache'}->{ $str } ||= { State => ON_STACK, Object => $obj } );
+}
+
+=head3 GetObject, GetState, GetRecord( String => ''| Object => '' )
+
+Returns record object from cache, cache entry state or cache entry accordingly.
+
+All three methods takes C<String> (format C<< <class>-<id> >>) or C<Object> argument.
+C<String> argument has more priority than C<Object> so if it's not empty then methods
+leave C<Object> argument unchecked.
+
+You can read about possible states and thier meaning in L<RT::Shredder::Constants> docs.
+
+=cut
+
+sub _ParseRefStrArgs
+{
+    my $self = shift;
+    my %args = (
+        String => '',
+        Object => undef,
+        @_
+    );
+    if( $args{'String'} && $args{'Object'} ) {
+        require Carp;
+        Carp::croak( "both String and Object args passed" );
+    }
+    return $args{'String'} if $args{'String'};
+    return $args{'Object'}->_AsString if UNIVERSAL::can($args{'Object'}, '_AsString' );
+    return '';
+}
+
+sub GetObject { return (shift)->GetRecord( @_ )->{'Object'} }
+sub GetState { return (shift)->GetRecord( @_ )->{'State'} }
+sub GetRecord
+{
+    my $self = shift;
+    my $str = $self->_ParseRefStrArgs( @_ );
+    return $self->{'cache'}->{ $str };
+}
+
+=head2 DEPENDENCIES RESOLVERS
+
+=cut
+
+sub PutResolver
+{
+    my $self = shift;
+    my %args = (
+        BaseClass => '',
+        TargetClass => '',
+        Code => undef,
+        @_,
+    );
+    unless( UNIVERSAL::isa( $args{'Code'} => 'CODE' ) ) {
+        die "Resolver '$args{Code}' is not code reference";
+    }
+
+    my $resolvers = (
+        (
+            $self->{'resolver'}->{ $args{'BaseClass'} } ||= {}
+        )->{  $args{'TargetClass'} || '' } ||= []
+    );
+    unshift @$resolvers, $args{'Code'};
+    return;
+}
+
+sub GetResolvers
+{
+    my $self = shift;
+    my %args = (
+        BaseClass => '',
+        TargetClass => '',
+        @_,
+    );
+
+    my @res;
+    if( $args{'TargetClass'} && exists $self->{'resolver'}->{ $args{'BaseClass'} }->{ $args{'TargetClass'} } ) {
+        push @res, @{ $self->{'resolver'}->{ $args{'BaseClass'} }->{ $args{'TargetClass'} || '' } };
+    }
+    if( exists $self->{'resolver'}->{ $args{'BaseClass'} }->{ '' } ) {
+        push @res, @{ $self->{'resolver'}->{ $args{'BaseClass'} }->{''} };
+    }
+
+    return @res;
+}
+
+sub ApplyResolvers
+{
+    my $self = shift;
+    my %args = ( Dependency => undef, @_ );
+    my $dep = $args{'Dependency'};
+
+    my @resolvers = $self->GetResolvers(
+        BaseClass   => $dep->BaseClass,
+        TargetClass => $dep->TargetClass,
+    );
+
+    unless( @resolvers ) {
+        die "Couldn't find resolver for dependency '". $dep->AsString ."'";
+    }
+    foreach( @resolvers ) {
+        eval { $_->(
+                Shredder  => $self,
+                BaseObject   => $dep->BaseObject,
+                TargetObject => $dep->TargetObject,
+        ) };
+        die "Resolver failed: $@" if $@;
+    }
+
+    return;
+}
+
+sub WipeoutAll
+{
+    my $self = $_[0];
+
+    foreach ( values %{ $self->{'cache'} } ) {
+        next if $_->{'State'} & (WIPED | IN_WIPING);
+        $self->Wipeout( Object => $_->{'Object'} );
+    }
+}
+
+sub Wipeout
+{
+    die "Couldn't begin transaction" unless $RT::Handle->BeginTransaction;
+
+    eval { (shift)->_Wipeout( @_ ) };
+    if( $@ ) {
+        $RT::Handle->Rollback('force');
+        die $@ if RT::Shredder::Exception::Info->caught;
+        die "Couldn't wipeout object: $@";
+    }
+
+    die "Couldn't commit transaction" unless $RT::Handle->Commit;
+}
+
+sub _Wipeout
+{
+    my $self = shift;
+    my %args = ( CacheRecord => undef, Object => undef, @_ );
+
+    my $record = $args{'CacheRecord'};
+    $record = $self->PutObject( Object => $args{'Object'} ) unless $record;
+    return if $record->{'State'} & (WIPED | IN_WIPING);
+
+    $record->{'State'} |= IN_WIPING;
+
+    my $object = $record->{'Object'};
+    unless( $object->BeforeWipeout ) {
+        RT::Shredder::Exception->throw( "BeforeWipeout check returned error" );
+    }
+    my $deps = $object->Dependencies( Shredder => $self );
+
+    $deps->List(
+        WithFlags => DEPENDS_ON | VARIABLE,
+        Callback  => sub { $self->ApplyResolvers( Dependency => $_[0] ) },
+    );
+    $deps->List(
+        WithFlags    => DEPENDS_ON,
+        WithoutFlags => WIPE_AFTER | VARIABLE,
+        Callback     => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) },
+    );
+
+    my $insert_query = $object->_AsInsertQuery;
+    $object->__Wipeout;
+    $self->DumpSQL( Query => $insert_query );
+    $record->{'State'} |= WIPED; delete $record->{'Object'};
+
+    $deps->List(
+        WithFlags => DEPENDS_ON | WIPE_AFTER,
+        WithoutFlags => VARIABLE,
+        Callback => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) },
+    );
+
+    return;
+}
+
+sub ValidateRelations
+{
+    my $self = shift;
+    my %args = ( @_ );
+
+    foreach my $record( values %{ $self->{'cache'} } ) {
+        next if( $record->{'State'} & VALID );
+        $record->{'Object'}->ValidateRelations( Shredder => $self );
+    }
+}
+
+=head2 DATA STORAGE AND BACKUPS
+
+Shredder allow you to store data you delete in files as scripts with SQL
+commands.
+
+=head3 SetFile( FileName => '<ISO DATETIME>-XXXX.sql', FromStorage => 1 )
+
+Calls C<GetFileName> method to check and translate file name, then checks
+if file is empty, opens it. After this you can dump records with C<DumpSQL>
+method.
+
+Returns name and handle.
+
+B<NOTE:> If file allready exists then file content would be overriden.
+Also in this situation method prints warning to the STDERR unless C<force>
+shredder's option is used.
+
+Examples:
+    # file from storage with default name format
+    my ($fname, $fh) = $shredder->SetFile;
+    # file from storage with custom name format
+    my ($fname, $fh) = $shredder->SetFile( FileName => 'shredder-XXXX.backup' );
+    # file with path relative to the current dir
+    my ($fname, $fh) = $shredder->SetFile( FromStorage => 0, FileName => 'backups/shredder.sql' );
+    # file with absolute path
+    my ($fname, $fh) = $shredder->SetFile( FromStorage => 0, FileName => '/var/backups/shredder-XXXX.sql' );
+
+=cut
+
+sub SetFile
+{
+    my $self = shift;
+    my $file = $self->GetFileName( @_ );
+    if( -s $file ) {
+        print STDERR "WARNING: file '$file' is not empty, content would be overwriten\n" unless $opt{'force'};
+    }
+    open my $fh, ">$file" or die "Couldn't open '$file' for write: $!";
+    ($self->{'opt'}->{'sqldump_fn'}, $self->{'opt'}->{'sqldump_fh'}) = ($file, $fh);
+    return ($file, $fh);
+}
+
+=head3 GetFileName( FileName => '<ISO DATETIME>-XXXX.sql', FromStorage => 1 )
+
+Takes desired C<FileName> and flag C<FromStorage> then translate file name to absolute
+path by next rules:
+* Default C<FileName> value is C<< <ISO DATETIME>-XXXX.sql >>;
+* if C<FileName> has C<XXXX> (exactly four uppercase C<X> letters) then it would be changed with
+digits from 0000 to 9999 range, with first one notexistant value;
+* if C<FromStorage> argument is true then result path would always be relative to C<StoragePath>;
+* if C<FromStorage> argument is false then result would be relative to the current dir unless it's
+allready absolute path.
+
+Returns file absolute path.
+
+See example for method C<SetFile>
+
+=cut
+
+sub GetFileName
+{
+    my $self = shift;
+    my %args = ( FileName => '', FromStorage => 1, @_ );
+
+    # default value
+    my $file = $args{'FileName'};
+    unless( $file ) {
+        require POSIX;
+        $file = POSIX::strftime("%Y%m%dT%H%M%S-XXXX.sql", gmtime );
+    }
+
+    # convert to absolute path
+    if( $args{'FromStorage'} ) {
+        $file = File::Spec->catfile( $self->StoragePath, $file );
+    } elsif( !File::Spec->file_name_is_absolute( $file ) ) {
+        $file = File::Spec->rel2abs( $file );
+    }
+
+    # check mask
+    if( $file =~ /XXXX[^\/\\]*$/ ) {
+        my( $tmp, $i ) = ( $file, 0 );
+        do {
+            $i++;
+            $tmp = $file;
+            $tmp =~ s/XXXX([^\/\\]*)$/sprintf("%04d", $i).$1/e;
+        } while( -e $tmp && $i < 9999 );
+        $file = $tmp;
+    }
+
+    if( -f $file ) {
+        unless( -w _ ) {
+            die "File '$file' exists, but is read-only";
+        }
+    } elsif( !-e _ ) {
+        unless( File::Spec->file_name_is_absolute( $file ) ) {
+            $file = File::Spec->rel2abs( $file );
+        }
+
+        # check base dir
+        my $dir = File::Spec->join( (File::Spec->splitpath( $file ))[0,1] );
+        unless( -e $dir && -d _) {
+            die "Base directory '$dir' for file '$file' doesn't exist";
+        }
+        unless( -w $dir ) {
+            die "Base directory '$dir' is not writable";
+        }
+    } else {
+        die "'$file' is not regular file";
+    }
+
+    return $file;
+}
+
+=head3 StoragePath
+
+Returns absolute path to storage dir. By default it's
+F</path-to-RT-var-dir/data/RTx-Shredder/>
+(in default RT install would be F</opt/rt3/var/data/RTx-Shredder>),
+but you can change this value with config option C<$RT::ShredderStoragePath>.
+See C<CONFIGURATION> sections in this doc.
+
+See C<SetFile> and C<GetFileName> methods description.
+
+=cut
+
+sub StoragePath
+{
+    return $RT::ShredderStoragePath if $RT::ShredderStoragePath;
+    return File::Spec->catdir( $RT::VarPath, qw(data RTx-Shredder) );
+}
+
+sub DumpSQL
+{
+    my $self = shift;
+    return unless exists $self->{'opt'}->{'sqldump_fh'};
+
+    my %args = ( Query => undef, @_ );
+    $args{'Query'} .= "\n" unless $args{'Query'} =~ /\n$/;
+
+    my $fh = $self->{'opt'}->{'sqldump_fh'};
+    return print $fh $args{'Query'} or die "Couldn't write to filehandle";
+}
+
+1;
+__END__
+
+=head1 NOTES
+
+=head2 Database transactions support
+
+Since RTx-Shredder-0.03_01 extension uses database transactions and should
+be much safer to run on production servers.
+
+=head2 Foreign keys
+
+Mainstream RT doesn't use FKs, but at least I posted DDL script that creates them
+in mysql DB, note that if you use FKs then this two valid keys don't allow delete
+Tickets because of bug in MySQL:
+
+  ALTER TABLE Tickets ADD FOREIGN KEY (EffectiveId) REFERENCES Tickets(id);
+  ALTER TABLE CachedGroupMembers ADD FOREIGN KEY (Via) REFERENCES CachedGroupMembers(id);
+
+L<http://bugs.mysql.com/bug.php?id=4042>
+
+=head1 BUGS AND HOW TO CONTRIBUTE
+
+I need your feedback in all cases: if you use it or not,
+is it works for you or not.
+
+=head2 Testing
+
+Don't skip C<make test> step while install and send me reports if it's fails.
+Add your own tests, it's easy enough if you've writen at list one perl script
+that works with RT. Read more about testing in F<t/utils.pl>.
+
+=head2 Reporting
+
+Send reports to L</AUTHOR> or to the RT mailing lists.
+
+=head2 Documentation
+
+Many bugs in the docs: insanity, spelling, gramar and so on.
+Patches are wellcome.
+
+=head2 Todo
+
+Please, see Todo file, it has some technical notes
+about what I plan to do, when I'll do it, also it
+describes some problems code has.
+
+=head2 Repository
+
+You can find repository of this project at
+L<https://opensvn.csie.org/rtx_shredder>
+
+=head1 AUTHOR
+
+    Ruslan U. Zakirov <Ruslan.Zakirov at gmail.com>
+
+=head1 COPYRIGHT
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+Perl distribution.
+
+=head1 SEE ALSO
+
+L<rtx-shredder>, L<rtx-validator>
+
+=cut
+

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ACE.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ACE.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,53 @@
+use RT::ACE ();
+package RT::ACE;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Exceptions;
+use RT::Shredder::Constants;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+1;
+

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Attachment.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Attachment.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,88 @@
+use RT::Attachment ();
+package RT::Attachment;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Exceptions;
+use RT::Shredder::Constants;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Nested attachments
+    my $objs = RT::Attachments->new( $self->CurrentUser );
+    $objs->Limit(
+            FIELD => 'Parent',
+            OPERATOR        => '=',
+            VALUE           => $self->Id
+           );
+    $objs->Limit(
+            FIELD => 'id',
+            OPERATOR        => '!=',
+            VALUE           => $self->Id
+           );
+    push( @$list, $objs );
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Parent, nested parts
+    if( $self->Parent ) {
+        if( $self->ParentObj && $self->ParentId ) {
+            push( @$list, $self->ParentObj );
+        } else {
+            my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+            $self = $rec->{'Object'};
+            $rec->{'State'} |= INVALID;
+            $rec->{'Description'} = "Have no parent attachment #". $self->Parent ." object";
+        }
+    }
+
+# Transaction
+    my $obj = $self->TransactionObj;
+    if( defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related transaction #". $self->TransactionId ." object";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CachedGroupMember.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CachedGroupMember.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,103 @@
+use RT::CachedGroupMember ();
+package RT::CachedGroupMember;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependency;
+
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# deep memebership
+    my $objs = RT::CachedGroupMembers->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'Via', VALUE => $self->Id );
+    $objs->Limit( FIELD => 'id', OPERATOR => '!=', VALUE => $self->Id );
+    push( @$list, $objs );
+
+# principal lost group membership and lost some rights which he could delegate to
+# some body
+
+# XXX: Here is problem cause HasMemberRecursively would return true allways
+# cause we didn't delete anything yet. :(
+    # if pricipal is not member anymore(could be via other groups) then proceed
+    if( $self->GroupObj->Object->HasMemberRecursively( $self->MemberObj ) ) {
+        my $acl = RT::ACL->new( $self->CurrentUser );
+        $acl->LimitToPrincipal( Id => $self->GroupId );
+
+        # look into all rights that have group
+        while( my $ace = $acl->Next ) {
+            my $delegations = RT::ACL->new( $self->CurrentUser );
+            $delegations->DelegatedFrom( Id => $ace->Id );
+            $delegations->DelegatedBy( Id => $self->MemberId );
+            push( @$list, $delegations );
+        }
+    }
+
+# XXX: Do we need to delete records if user lost right 'DelegateRights'?
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+#TODO: If we plan write export tool we also should fetch parent groups
+# now we only wipeout things.
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    my $obj = $self->MemberObj;
+    if( $obj && $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Principal #". $self->MemberId ." object.";
+    }
+
+    $obj = $self->GroupObj;
+    if( $obj && $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Principal #". $self->GroupId ." object.";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Constants.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Constants.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,93 @@
+package RT::Shredder::Constants;
+
+use base qw(Exporter);
+
+=head1 NAME
+
+RT::Shredder::Constants -  RT::Shredder constants that is used to mark state of RT objects.
+
+=head1 DESCRIPTION
+
+This module exports two group of bit constants.
+First group is group of flags which are used to clarify dependecies between objects, and
+second group is states of RT objects in Shredder cache.
+
+=head1 FLAGS
+
+=head2 DEPENDS_ON
+
+Targets that has such dependency flag set should be wiped out with base object.
+
+=head2 WIPE_AFTER
+
+If dependency has such flag then target object would be wiped only
+after base object. You should mark dependencies with this flag
+if two objects depends on each other, for example Group and Principal
+have such relationship, this mean Group depends on Principal record and
+that Principal record depends on the same Group record. Other examples:
+User and Principal, User and its ACL equivalence group.
+
+=head2 VARIABLE
+
+This flag is used to mark dependencies that can be resolved with changing
+value in target object. For example ticket can be created by user we can
+change this reference when we delete user.
+
+=head2 RELATES
+
+This flag is used to validate relationships integrity. Base object
+is valid only when all target objects which are marked with this flags
+exist.
+
+=cut
+
+use constant {
+    DEPENDS_ON    => 0x000001,
+    WIPE_AFTER    => 0x000010,
+    RELATES        => 0x000100,
+    VARIABLE    => 0x001000,
+};
+
+=head1 STATES
+
+=head2 ON_STACK
+
+Default state of object in Shredder cache that means that object is
+loaded and placed into cache.
+
+=head2 WIPED
+
+Objects with this state are not exist any more in DB, but perl
+object is still in memory. This state is used to be shure that
+delete query is called once.
+
+=head2 VALID
+
+Object is marked with this state only when its relationships
+are valid.
+
+=head2 INVALID
+
+=cut
+
+use constant {
+    ON_STACK    => 0x00000,
+    IN_WIPING    => 0x00001,
+    WIPED        => 0x00010,
+    VALID        => 0x00100,
+    INVALID        => 0x01000,
+};
+
+our @EXPORT = qw(
+        DEPENDS_ON
+        WIPE_AFTER
+        RELATES
+        VARIABLE
+        ON_STACK
+        IN_WIPING
+        WIPED
+        VALID
+        INVALID
+        );
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CustomField.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CustomField.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,78 @@
+use RT::CustomField ();
+package RT::CustomField;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+#TODO: Queues if we wish export tool
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Custom field values
+    push( @$list, $self->Values );
+
+# Ticket custom field values
+    my $objs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
+    $objs->LimitToCustomField( $self->Id );
+    push( @$list, $objs );
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    my $obj = $self->Object;
+
+# Queue
+# Skip if it's global CF
+    if( $self->Queue ) {
+        if( $self->QueueObj && $self->QueueObj->Id ) {
+            push( @$list, $obj );
+        } else {
+            my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+            $self = $rec->{'Object'};
+            $rec->{'State'} |= INVALID;
+            $rec->{'Description'} = "Have no related queue #". $self->Queue ." object";
+        }
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+1;
+

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CustomFieldValue.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/CustomFieldValue.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,46 @@
+use RT::CustomFieldValue ();
+package RT::CustomFieldValue;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+# No dependencies that should be deleted with record
+# I should decide is TicketCustomFieldValue depends by this or not.
+# Today I think no. What would be tomorrow I don't know.
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    my $obj = $self->CustomFieldObj;
+    if( $obj && defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related CustomField #". $self->id ." object";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Dependencies.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Dependencies.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,101 @@
+package RT::Shredder::Dependencies;
+
+use strict;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Constants;
+use RT::Shredder::Dependency;
+use RT::Record;
+
+
+
+=head1 METHODS
+
+=head2 new
+
+Creates new empty collection of dependecies.
+
+=cut
+
+sub new
+{
+    my $proto = shift;
+    my $self = bless( {}, ref $proto || $proto );
+    $self->{'list'} = [];
+    return $self;
+}
+
+=head2 _PushDependencies
+
+Put in objects into collection.
+Takes
+BaseObject - any supported object of RT::Record subclass;
+Flags - flags that describe relationship between target and base objects;
+TargetObjects - any of RT::SearchBuilder or RT::Record subclassed objects
+or array ref on list of this objects;
+Shredder - RT::Shredder object.
+
+SeeAlso: _PushDependecy, RT::Shredder::Dependency
+
+=cut
+
+sub _PushDependencies
+{
+    my $self = shift;
+    my %args = ( TargetObjects => undef, Shredder => undef, @_ );
+    my @objs = $args{'Shredder'}->CastObjectsToRecords( Objects => delete $args{'TargetObjects'} );
+    $self->_PushDependency( %args, TargetObject => $_ ) foreach @objs;
+    return;
+}
+
+sub _PushDependency
+{
+    my $self = shift;
+    my %args = (
+            BaseObject => undef,
+            Flags => undef,
+            TargetObject => undef,
+            Shredder => undef,
+            @_
+           );
+    my $rec = $args{'Shredder'}->PutObject( Object => $args{'TargetObject'} );
+    return if $rec->{'State'} & WIPED; # there is no object anymore
+
+    push @{ $self->{'list'} },
+        RT::Shredder::Dependency->new(
+            BaseObject => $args{'BaseObject'},
+            Flags => $args{'Flags'},
+            TargetObject => $rec->{'Object'},
+        );
+
+    if( scalar @{ $self->{'list'} } > ( $RT::DependenciesLimit || 1000 ) ) {
+        RT::Shredder::Exception::Info->throw( 'DependenciesLimit' );
+    }
+    return;
+}
+
+=head2 List
+
+
+=cut
+
+sub List
+{
+    my $self = shift;
+    my %args = (
+        WithFlags => undef,
+        WithoutFlags => undef,
+        Callback => undef,
+        @_
+    );
+
+    my $wflags = delete $args{'WithFlags'};
+    my $woflags = delete $args{'WithoutFlags'};
+
+    return
+        map $args{'Callback'}? $args{'Callback'}->($_): $_,
+        grep !defined( $wflags ) || ($_->Flags & $wflags) == $wflags,
+        grep !defined( $woflags ) || !($_->Flags & $woflags),
+        @{ $self->{'list'} };
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Dependency.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Dependency.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,64 @@
+package RT::Shredder::Dependency;
+
+use strict;
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+
+my %FlagDescs = (
+    DEPENDS_ON, 'depends on',
+    VARIABLE,   'resolvable dependency',
+    WIPE_AFTER, 'delete after',
+    RELATES,    'relates with',
+);
+
+sub new
+{
+    my $proto = shift;
+    my $self = bless( {}, ref $proto || $proto );
+    $self->Set( @_ );
+    return $self;
+}
+
+sub Set
+{
+    my $self = shift;
+    my %args = ( Flags => DEPENDS_ON, @_ );
+    my @keys = qw(Flags BaseObject TargetObject);
+    @$self{ @keys } = @args{ @keys };
+
+    return;
+}
+
+sub AsString
+{
+    my $self = shift;
+    my $res = $self->BaseObject->_AsString;
+    $res .= " ". $self->FlagsAsString;
+    $res .= " ". $self->TargetObject->_AsString;
+    return $res;
+}
+
+sub Flags { return $_[0]->{'Flags'} }
+sub FlagsAsString
+{
+    my $self = shift;
+    my @res = ();
+    foreach ( sort keys %FlagDescs ) {
+        if( $self->Flags() & $_ ) {
+            push( @res, $FlagDescs{ $_ } );
+        }
+    }
+    push @res, 'no flags' unless( @res );
+    return "(" . join( ',', @res ) . ")";
+}
+
+
+sub BaseObject { return $_[0]->{'BaseObject'} }
+sub TargetObject { return $_[0]->{'TargetObject'} }
+sub Object { return shift()->{ ({@_})->{Type}. "Object" } }
+
+sub TargetClass { return ref $_[0]->{'TargetObject'} }
+sub BaseClass {    return ref $_[0]->{'BaseObject'} }
+sub Class { return ref shift()->Object( @_ ) }
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Exceptions.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Exceptions.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,49 @@
+package RT::Shredder::Exception;
+
+use warnings;
+use strict;
+
+use Exception::Class;
+use base qw(Exception::Class::Base);
+
+BEGIN {
+    __PACKAGE__->NoRefs(0);
+}
+
+#sub NoRefs { return 0 }
+sub show_trace { return 1 }
+
+package RT::Shredder::Exception::Info;
+
+use base qw(RT::Shredder::Exception);
+
+my %DESCRIPTION = (
+    DependenciesLimit => <<END,
+Dependecies list have reached its limit.
+See \$RT::DependenciesLimit in RT::Shredder docs.
+END
+
+    SystemObject => <<END,
+System object was requested for deletion, shredder couldn't
+do that because system would be unusable than.
+END
+
+    CouldntLoadObject => <<END,
+Shredder couldn't load object. Most probably it's not fatal error.
+May be you've used Objects plugin and asked to delete object that
+doesn't exist in the system. If you think that your request was
+correct and it's problem of the Shredder then you can get full error
+message from RT log files and send bug report.
+END
+
+);
+
+sub full_message {
+    my $self = shift;
+    my $error = $self->message;
+    return $DESCRIPTION{$error} || $error;
+}
+
+sub show_trace { return 0 }
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Group.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Group.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,137 @@
+use RT::Group ();
+package RT::Group;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+        Shredder => undef,
+        Dependencies => undef,
+        @_,
+    );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# User is inconsistent without own Equivalence group
+    if( $self->Domain eq 'ACLEquivalence' ) {
+        # delete user entry after ACL equiv group
+        # in other case we will get deep recursion
+        my $objs = RT::User->new($self->CurrentUser);
+        $objs->Load( $self->Instance );
+        $deps->_PushDependency(
+                BaseObject => $self,
+                Flags => DEPENDS_ON | WIPE_AFTER,
+                TargetObject => $objs,
+                Shredder => $args{'Shredder'}
+            );
+    }
+
+# Principal
+    $deps->_PushDependency(
+            BaseObject => $self,
+            Flags => DEPENDS_ON | WIPE_AFTER,
+            TargetObject => $self->PrincipalObj,
+            Shredder => $args{'Shredder'}
+        );
+
+# Group members records
+    my $objs = RT::GroupMembers->new( $self->CurrentUser );
+    $objs->LimitToMembersOfGroup( $self->PrincipalId );
+    push( @$list, $objs );
+
+# Group member records group belongs to
+    $objs = RT::GroupMembers->new( $self->CurrentUser );
+    $objs->Limit(
+            VALUE => $self->PrincipalId,
+            FIELD => 'MemberId',
+            ENTRYAGGREGATOR => 'OR',
+            QUOTEVALUE => 0
+            );
+    push( @$list, $objs );
+
+# Cached group members records
+    push( @$list, $self->DeepMembersObj );
+
+# Cached group member records group belongs to
+    $objs = RT::GroupMembers->new( $self->CurrentUser );
+    $objs->Limit(
+            VALUE => $self->PrincipalId,
+            FIELD => 'MemberId',
+            ENTRYAGGREGATOR => 'OR',
+            QUOTEVALUE => 0
+            );
+    push( @$list, $objs );
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Equivalence group id inconsistent without User
+    if( $self->Domain eq 'ACLEquivalence' ) {
+        my $obj = RT::User->new($self->CurrentUser);
+        $obj->Load( $self->Instance );
+        if( $obj->id ) {
+            push( @$list, $obj );
+        } else {
+            my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+            $self = $rec->{'Object'};
+            $rec->{'State'} |= INVALID;
+            $rec->{'Description'} = "ACLEguvivalence group have no related User #". $self->Instance ." object.";
+        }
+    }
+
+# Principal
+    my $obj = $self->PrincipalObj;
+    if( $obj && $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Principal #". $self->id ." object.";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+sub BeforeWipeout
+{
+    my $self = shift;
+    if( $self->Domain eq 'SystemInternal' ) {
+        RT::Shredder::Exception::Info->throw('SystemObject');
+    }
+    return $self->SUPER::BeforeWipeout( @_ );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/GroupMember.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/GroupMember.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,135 @@
+use RT::GroupMember ();
+package RT::GroupMember;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+# No dependencies that should be deleted with record
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    my $objs = RT::CachedGroupMembers->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'MemberId', VALUE => $self->MemberId );
+    $objs->Limit( FIELD => 'ImmediateParentId', VALUE => $self->GroupId );
+    push( @$list, $objs );
+
+    # XXX: right delegations should be cleaned here
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+
+    my $group = $self->GroupObj->Object;
+    # XXX: If we delete member of the ticket owner role group then we should also
+    # fix ticket object, but only if we don't plan to delete group itself!
+    unless( ($group->Type || '') eq 'Owner' &&
+        ($group->Domain || '') eq 'RT::Ticket-Role' ) {
+        return $self->SUPER::__DependsOn( %args );
+    }
+
+    # we don't delete group, so we have to fix Ticket and Group
+    $deps->_PushDependencies(
+                BaseObject => $self,
+                Flags => DEPENDS_ON | VARIABLE,
+                TargetObjects => $group,
+                Shredder => $args{'Shredder'}
+        );
+    $args{'Shredder'}->PutResolver(
+            BaseClass => ref $self,
+            TargetClass => ref $group,
+            Code => sub {
+                my %args = (@_);
+                my $group = $args{'TargetObject'};
+                return if $args{'Shredder'}->GetState( Object => $group ) & (WIPED|IN_WIPING);
+                return unless ($group->Type || '') eq 'Owner';
+                return unless ($group->Domain || '') eq 'RT::Ticket-Role';
+
+                return if $group->MembersObj->Count > 1;
+
+                my $group_member = $args{'BaseObject'};
+
+                if( $group_member->MemberObj->id == $RT::Nobody->id ) {
+                    RT::Shredder::Exception->throw( "Couldn't delete Nobody from owners role group" );
+                }
+
+                my( $status, $msg ) = $group->AddMember( $RT::Nobody->id );
+                RT::Shredder::Exception->throw( $msg ) unless $status;
+
+                my $ticket = RT::Ticket->new( $group->CurrentUser );
+                $ticket->Load( $group->Instance );
+                RT::Shredder::Exception->throw( "Couldn't load ticket" ) unless $ticket->id;
+
+                ( $status, $msg ) = $ticket->_Set( Field => 'Owner',
+                                   Value => $RT::Nobody->id,
+                                 );
+                RT::Shredder::Exception->throw( $msg ) unless $status;
+
+                return;
+            },
+        );
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+
+#TODO: If we plan write export tool we also should fetch parent groups
+# now we only wipeout things.
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    my $obj = $self->MemberObj;
+    if( $obj && $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Principal #". $self->MemberId ." object.";
+    }
+
+    $obj = $self->GroupObj;
+    if( $obj && $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Principal #". $self->GroupId ." object.";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Link.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Link.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,92 @@
+use RT::Link ();
+package RT::Link;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+use RT::Shredder::Constants;
+
+use RT::Shredder::Transaction;
+use RT::Shredder::Record;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# AddLink transactions
+    my $map = RT::Ticket->LINKTYPEMAP;
+    my $link_meta = $map->{ $self->Type };
+    unless ( $link_meta && $link_meta->{'Mode'} && $link_meta->{'Type'} ) {
+        RT::Shredder::Exception->throw( 'Wrong link link_meta, no record for '. $self->Type );
+    }
+    if ( $self->BaseURI->IsLocal ) {
+        my $objs = $self->BaseObj->Transactions;
+        $objs->Limit(
+            FIELD    => 'Type',
+            OPERATOR => '=',
+            VALUE    => 'AddLink',
+        );
+        $objs->Limit( FIELD => 'NewValue', VALUE => $self->Target );
+        while ( my ($k, $v) = each %$map ) {
+            next unless $v->{'Type'} eq $link_meta->{'Type'};
+            next unless $v->{'Mode'} eq $link_meta->{'Mode'};
+            $objs->Limit( FIELD => 'Field', VALUE => $k );
+        }
+        push( @$list, $objs );
+    }
+
+    my %reverse = ( Base => 'Target', Target => 'Base' );
+    if ( $self->TargetURI->IsLocal ) {
+        my $objs = $self->TargetObj->Transactions;
+        $objs->Limit(
+            FIELD    => 'Type',
+            OPERATOR => '=',
+            VALUE    => 'AddLink',
+        );
+        $objs->Limit( FIELD => 'NewValue', VALUE => $self->Base );
+        while ( my ($k, $v) = each %$map ) {
+            next unless $v->{'Type'} eq $link_meta->{'Type'};
+            next unless $v->{'Mode'} eq $reverse{ $link_meta->{'Mode'} };
+            $objs->Limit( FIELD => 'Field', VALUE => $k );
+        }
+        push( @$list, $objs );
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON|WIPE_AFTER,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__DependsOn( %args );
+}
+
+#TODO: Link record has small strength, but should be encountered
+# if we plan write export tool.
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+# FIXME: if link is local then object should exist
+
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ObjectCustomFieldValue.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ObjectCustomFieldValue.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,68 @@
+use RT::ObjectCustomFieldValue ();
+package RT::ObjectCustomFieldValue;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Ticket
+    my $obj = $self->TicketObj;
+    if( defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Ticket #". $self->id ." object";
+    }
+
+# Custom Field
+    $obj = $self->CustomFieldObj;
+    if( defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related CustomField #". $self->id ." object";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/POD.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/POD.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,83 @@
+package RT::Shredder::POD;
+
+use strict;
+use warnings;
+use Pod::Select;
+
+sub plugin_html
+{
+    my ($file, $out_fh) = @_;
+    my $parser = new RT::Shredder::POD::HTML;
+    $parser->select('ARGUMENTS', 'USAGE');
+    $parser->parse_from_file( $file, $out_fh );
+}
+
+sub plugin_cli
+{
+    my ($file, $out_fh, $no_name) = @_;
+    use Pod::PlainText;
+    local @Pod::PlainText::ISA = ('Pod::Select', @Pod::PlainText::ISA);
+    my $parser = new Pod::PlainText;
+    $parser->select('SYNOPSIS', 'ARGUMENTS', 'USAGE');
+    $parser->add_selection('NAME') unless $no_name;
+    $parser->parse_from_file( $file, $out_fh );
+}
+
+sub shredder_cli
+{
+    my ($file, $out_fh) = @_;
+    use Pod::PlainText;
+    local @Pod::PlainText::ISA = ('Pod::Select', @Pod::PlainText::ISA);
+    my $parser = new Pod::PlainText;
+    $parser->select('NAME', 'SYNOPSIS', 'USAGE', 'OPTIONS');
+    $parser->parse_from_file( $file, $out_fh );
+}
+
+package RT::Shredder::POD::HTML;
+use base qw(Pod::Select);
+
+sub command
+{
+    my( $self, $command, $paragraph, $line_num ) = @_;
+
+    my $tag;
+    if ($command =~ /^head(\d+)$/) { $tag = "h$1" }
+    my $out_fh = $self->output_handle();
+    my $expansion = $self->interpolate($paragraph, $line_num);
+    $expansion =~ s/^\s+|\s+$//;
+
+    print $out_fh "<$tag>" if $tag;
+    print $out_fh $expansion;
+    print $out_fh "</$tag>" if $tag;
+    print $out_fh "\n";
+}
+
+sub verbatim
+{
+    my ($self, $paragraph, $line_num) = @_;
+    my $out_fh = $self->output_handle();
+    print $out_fh "<pre>";
+    print $out_fh $paragraph;
+    print $out_fh "</pre>";
+    print $out_fh "\n";
+}
+
+sub textblock {
+    my ($self, $paragraph, $line_num) = @_;
+    my $out_fh = $self->output_handle();
+    my $expansion = $self->interpolate($paragraph, $line_num);
+    $expansion =~ s/^\s+|\s+$//;
+    print $out_fh "<p>";
+    print $out_fh $expansion;
+    print $out_fh "</p>";
+    print $out_fh "\n";
+}
+
+sub interior_sequence {
+    my ($self, $seq_command, $seq_argument) = @_;
+    ## Expand an interior sequence; sample actions might be:
+    return "<b>$seq_argument</b>" if $seq_command eq 'B';
+    return "<i>$seq_argument</i>" if $seq_command eq 'I';
+    return "<span class=\"pod-sequence-$seq_command\">$seq_argument</span>";
+}
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,183 @@
+package RT::Shredder::Plugin;
+
+use strict;
+use warnings FATAL => 'all';
+use File::Spec ();
+
+=head1 NAME
+
+RT::Shredder::Plugin - interface to access shredder plugins
+
+=head1 SYNOPSIS
+
+  use RT::Shredder::Plugin;
+
+  # get list of the plugins
+  my %plugins = RT::Shredder::Plugin->List;
+
+  # load plugin by name
+  my $plugin = new RT::Shredder::Plugin;
+  my( $status, $msg ) = $plugin->LoadByString( 'Tickets' );
+  unless( $status ) {
+      print STDERR "Couldn't load plugin 'Tickets': $msg\n";
+      exit(1);
+  }
+
+  # load plugin by preformatted string
+  my $plugin = new RT::Shredder::Plugin;
+  my( $status, $msg ) = $plugin->LoadByString( 'Tickets=status,deleted' );
+  unless( $status ) {
+      print STDERR "Couldn't load plugin: $msg\n";
+      exit(1);
+  }
+
+=head1 METHODS
+
+=head2 new
+
+Object constructor, returns new object. Takes optional hash
+as arguments, it's not required and this class doesn't use it,
+but plugins could define some arguments and can handle them
+after your've load it.
+
+=cut
+
+sub new
+{
+    my $proto = shift;
+    my $self = bless( {}, ref $proto || $proto );
+    $self->_Init( @_ );
+    return $self;
+}
+
+sub _Init
+{
+    my $self = shift;
+    my %args = ( @_ );
+    $self->{'opt'} = \%args;
+}
+
+=head2 List
+
+Returns hash with names of the available plugins as keys and path to
+library files as values. Method has no arguments. Can be used as class
+method too.
+
+=cut
+
+sub List
+{
+    my $self = shift;
+    my @files;
+    foreach my $root( @INC ) {
+        my $mask = File::Spec->catdir( $root, qw(RT Shredder Plugin *.pm) );
+        push @files, glob $mask;
+    }
+
+    my %res = map { $_ =~ m/([^\\\/]+)\.pm$/; $1 => $_ } reverse @files;
+
+    return %res;
+}
+
+=head2 LoadByName
+
+Takes name of the plugin as first argument, loads plugin,
+creates new plugin object and reblesses self into plugin
+if all steps were successfuly finished, then you don't need to
+create new object for the plugin.
+
+Other arguments are sent to the constructor of the plugin
+(method new.)
+
+Returns C<$status> and C<$message>. On errors status
+is C<false> value.
+
+=cut
+
+sub LoadByName
+{
+    my $self = shift;
+    my $name = shift or return (0, "Name not specified");
+
+    local $@;
+    my $plugin = "RT::Shredder::Plugin::$name";
+    eval "require $plugin";
+    return( 0, $@ ) if $@;
+
+    my $obj = eval { $plugin->new( @_ ) };
+    return( 0, $@ ) if $@;
+    return( 0, 'constructor returned empty object' ) unless $obj;
+
+    $self->Rebless( $obj );
+    return( 1, "successfuly load plugin" );
+}
+
+=head2 LoadByString
+
+Takes formatted string as first argument and which is used to
+load plugin. The format of the string is
+
+  <plugin name>[=<arg>,<val>[;<arg>,<val>]...]
+
+exactly like in the L<rtx-shredder> script. All other
+arguments are sent to the plugins constructor.
+
+Method does the same things as C<LoadByName>, but also
+checks if the plugin supports arguments and values are correct,
+so you can C<Run> specified plugin immediatly.
+
+Returns list with C<$status> and C<$message>. On errors status
+is C<false>.
+
+=cut
+
+sub LoadByString
+{
+    my $self = shift;
+    my ($plugin, $args) = split /=/, ( shift || '' ), 2;
+
+    my ($status, $msg) = $self->LoadByName( $plugin, @_ );
+    return( $status, $msg ) unless $status;
+
+    my %args;
+    foreach( split /\s*;\s*/, ( $args || '' ) ) {
+        my( $k,$v ) = split /\s*,\s*/, ( $_ || '' ), 2;
+        unless( $args{$k} ) {
+            $args{$k} = $v;
+            next;
+        }
+
+        $args{$k} = [ $args{$k} ] unless UNIVERSAL::isa( $args{ $k }, 'ARRAY');
+        push @{ $args{$k} }, $v;
+    }
+
+    ($status, $msg) = $self->HasSupportForArgs( keys %args );
+    return( $status, $msg ) unless $status;
+
+    ($status, $msg) = $self->TestArgs( %args );
+    return( $status, $msg ) unless $status;
+
+    return( 1, "successfuly load plugin" );
+}
+
+=head2 Rebless
+
+Instance method that takes one object as argument and rebless
+the current object into into class of the argument and copy data
+of the former. Returns nothing.
+
+Method is used by C<Load*> methods to automaticaly rebless
+C<RT::Shredder::Plugin> object into class of the loaded
+plugin.
+
+=cut
+
+sub Rebless
+{
+    my( $self, $obj ) = @_;
+    bless( $self, ref $obj );
+    %{$self} = %{$obj};
+    return;
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Attachments.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Attachments.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,97 @@
+package RT::Shredder::Plugin::Attachments;
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(RT::Shredder::Plugin::Base);
+
+=head1 NAME
+
+RT::Shredder::Plugin::Attachments - search plugin for wiping attachments.
+
+=cut
+
+sub Type { return 'search' }
+
+=head1 ARGUMENTS
+
+=head2 files_only - boolean value
+
+Search only file attachments.
+
+=head2 file - mask
+
+Search files with specific file name only.
+
+Example: '*.xl?' or '*.gif'
+
+=head2 longer - attachment content size
+
+Search attachments which content is longer than specified.
+You can use trailing 'K' or 'M' character to specify size in
+kilobytes or megabytes.
+
+=cut
+
+sub SupportArgs { return $_[0]->SUPER::SupportArgs, qw(files_only file longer) }
+
+sub TestArgs
+{
+    my $self = shift;
+    my %args = @_;
+    my $queue;
+    if( $args{'file'} ) {
+        unless( $args{'file'} =~ /^[\w\. *?]+$/) {
+            return( 0, "Files mask '$args{file}' has invalid characters" );
+        }
+        $args{'file'} = $self->ConvertMaskToSQL( $args{'file'} );
+    }
+    if( $args{'longer'} ) {
+        unless( $args{'longer'} =~ /^\d+\s*[mk]?$/i ) {
+            return( 0, "Invalid file size argument '$args{longer}'" );
+        }
+    }
+    return $self->SUPER::TestArgs( %args );
+}
+
+sub Run
+{
+    my $self = shift;
+    my @conditions = ();
+    my @values = ();
+    if( $self->{'opt'}{'file'} ) {
+        my $mask = $self->{'opt'}{'file'};
+        push @conditions, "( Filename LIKE ? )";
+        push @values, $mask;
+    }
+    if( $self->{'opt'}{'files_only'} ) {
+        push @conditions, "( LENGTH(Filename) > 0 )";
+    }
+    if( $self->{'opt'}{'longer'} ) {
+        my $size = $self->{'opt'}{'longer'};
+        $size =~ s/([mk])//i;
+        $size *= 1024 if $1 && lc $1 eq 'k';
+        $size *= 1024*1024 if $1 && lc $1 eq 'm';
+        push @conditions, "( LENGTH(Content) > ? )";
+        push @values, $size;
+    }
+    return (0, "At least one condition should be provided" ) unless @conditions;
+    my $query = "SELECT id FROM Attachments WHERE ". join ' AND ', @conditions;
+    if( $self->{'opt'}{'limit'} ) {
+        $RT::Handle->ApplyLimits( \$query, $self->{'opt'}{'limit'} );
+    }
+    my $sth = $RT::Handle->SimpleQuery( $query, @values );
+    return (0, "Internal error: '$sth'. Please send bug report.") unless $sth;
+
+    my @objs;
+    while( my $row = $sth->fetchrow_arrayref ) {
+        push @objs, $row->[0];
+    }
+    return (0, "Internal error: '". $sth->err ."'. Please send bug report.") if $sth->err;
+
+    map { $_ = "RT::Attachment-$_" } @objs;
+
+    return (1, @objs);
+}
+
+1;
+

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Base.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Base.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,156 @@
+package RT::Shredder::Plugin::Base;
+
+use strict;
+use warnings FATAL => 'all';
+
+=head1 NAME
+
+RT::Shredder::Plugin::Base - base class for Shredder plugins.
+
+=cut
+
+sub new
+{
+    my $proto = shift;
+    my $self = bless( {}, ref $proto || $proto );
+    $self->_Init( @_ );
+    return $self;
+}
+
+sub _Init
+{
+    my $self = shift;
+    $self->{'opt'} = { @_ };
+}
+
+=head1 USAGE
+
+=head2 masks
+
+If any argument is marked with keyword C<mask> then it means
+that this argument support two special characters:
+
+1) C<*> matches any non empty sequence of the characters.
+For example C<*@example.com> will match any email address in
+C<example.com> domain.
+
+2) C<?> matches exactly one character.
+For example C<????> will match any string four characters long.
+
+=head1 ARGUMENTS
+
+Arguments which all plugins support.
+
+=head2 limit - unsigned integer
+
+Allow you to limit search results. B<< Default value is C<10> >>.
+
+=head1 METHODS
+
+=head2 for subclassing in plugins
+
+=head3 Type - is not supported yet
+
+See F<Todo> for more info.
+
+=cut
+
+sub Type { return '' }
+
+=head3 SupportArgs
+
+Takes nothing.
+Returns list of the supported plugin arguments.
+
+Base class returns list of the arguments which all
+classes B<must> support.
+
+=cut
+
+sub SupportArgs { return qw(limit) }
+
+=head3 HasSupportForArgs
+
+Takes list of the argument names.
+Returns true if all arguments are supported by plugin
+and returns C<(0, $msg)> in other case.
+
+=cut
+
+sub HasSupportForArgs
+{
+    my $self = shift;
+    my @args = @_;
+    my @unsupported = ();
+    foreach my $a( @args ) {
+        push @unsupported, $a unless grep $_ eq $a, $self->SupportArgs;
+    }
+    return( 1 ) unless @unsupported;
+    return( 0, "Plugin doesn't support argument(s): @unsupported" ) if @unsupported;
+}
+
+=head3 TestArgs
+
+Takes hash with arguments and thier values and returns true
+if all values pass testing otherwise returns C<(0, $msg)>.
+
+Stores arguments hash in C<$self->{'opt'}>, you can access this hash
+from C<Run> method.
+
+Method should be subclassed if plugin support non standard arguments.
+
+=cut
+
+sub TestArgs
+{
+    my $self = shift;
+    my %args = @_;
+    if( defined $args{'limit'} && $args{'limit'} ne '' ) {
+        my $limit = $args{'limit'};
+        $limit =~ s/[^0-9]//g;
+        unless( $args{'limit'} eq $limit ) {
+            return( 0, "Argmument limit should be an unsigned integer");
+        }
+        $args{'limit'} = $limit;
+    } else {
+        $args{'limit'} = 10;
+    }
+    $self->{'opt'} = \%args;
+    return 1;
+}
+
+=head3 Run
+
+Takes no arguments.
+Executes plugin and return C<(1, @objs)> on success or
+C<(0, $msg)> if error had happenned.
+
+Method B<must> be subclassed, this class always returns error.
+
+Method B<must> be called only after C<TestArgs> method in other
+case values of the arguments are not available.
+
+=cut
+
+sub Run { return (0, "This is abstract plugin, you couldn't use it directly") }
+
+sub SetResolvers { return (1) }
+
+=head2 utils
+
+=head3 ConvertMaskToSQL
+
+Takes one argument - mask with C<*> and C<?> chars and
+return mask SQL chars.
+
+=cut
+
+sub ConvertMaskToSQL {
+    my $self = shift;
+    my $mask = shift || '';
+    $mask =~ s/\*/%/g;
+    $mask =~ s/\?/_/g;
+    return $mask;
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Objects.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Objects.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,64 @@
+package RT::Shredder::Plugin::Objects;
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(RT::Shredder::Plugin::Base);
+
+use RT::Shredder;
+
+=head1 NAME
+
+RT::Shredder::Plugin::Objects - search plugin for wiping any selected object.
+
+=cut
+
+sub Type { return 'search' }
+
+=head1 ARGUMENTS
+
+This plugin searches and RT object you want, so you can use
+the object name as argument and id as value, for example if
+you want select ticket #123 then from CLI you write next
+command:
+
+  rtx-shredder --plugin 'Objects=Ticket,123'
+
+=cut
+
+sub SupportArgs
+{
+    return $_[0]->SUPER::SupportArgs, @RT::Shredder::SUPPORTED_OBJECTS;
+}
+
+sub TestArgs
+{
+    my $self = shift;
+    my %args = @_;
+
+    my @strings;
+    foreach my $name( @RT::Shredder::SUPPORTED_OBJECTS ) {
+        next unless $args{$name};
+
+        my $list = $args{$name};
+        $list = [$list] unless UNIVERSAL::isa( $list, 'ARRAY' );
+        push @strings, map "RT::$name\-$_", @$list;
+    }
+
+    my @objs = RT::Shredder->CastObjectsToRecords( Objects => \@strings );
+
+    my @res = $self->SUPER::TestArgs( %args );
+
+    $self->{'opt'}->{'objects'} = \@objs;
+
+    return (@res);
+}
+
+sub Run
+{
+    my $self = shift;
+    my %args = ( Shredder => undef, @_ );
+    return (1, @{$self->{'opt'}->{'objects'}});
+}
+
+1;
+

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Tickets.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Tickets.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,86 @@
+package RT::Shredder::Plugin::Tickets;
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(RT::Shredder::Plugin::Base);
+
+=head1 NAME
+
+RT::Shredder::Plugin::Tickets - search plugin for wiping tickets.
+
+=cut
+
+sub Type { return 'search' }
+
+=head1 ARGUMENTS
+
+=head2 queue - queue name
+
+Search tickets only in particular queue.
+
+=head2 status - ticket status
+
+Search tickets with specified status only.
+'deleted' status is also supported.
+
+=head2 updated_before - date
+
+Search tickets that were updated before some date.
+Example: '2003-12-31 23:59:59'
+
+=cut
+
+sub SupportArgs { return $_[0]->SUPER::SupportArgs, qw(queue status updated_before) }
+
+sub TestArgs
+{
+    my $self = shift;
+    my %args = @_;
+    my $queue;
+    if( $args{'queue'} ) {
+        $queue = RT::Queue->new( $RT::SystemUser );
+        $queue->Load( $args{'queue'} );
+        return( 0, "Couldn't load queue '$args{'queue'}'" ) unless $queue->id;
+    }
+    if( $args{'status'} ) {
+        $queue ||= RT::Queue->new( $RT::SystemUser );
+        my @statuses = qw(new open stalled deleted rejected);
+        if( $queue->can( 'StatusArray' ) ) {
+            @statuses = $queue->StatusArray;
+        }
+        unless( grep $_ eq $args{'status'}, @statuses ) {
+            return( 0, "Invalid status '$args{status}'" );
+        }
+    }
+    if( $args{'updated_before'} ) {
+        unless( $args{'updated_before'} =~ /\d\d\d\d-\d\d-\d\d(?:\s\d\d:\d\d:\d\d)?/ ) {
+            return( 0, "Invalid date '$args{updated_before}'" );
+        }
+    }
+    return $self->SUPER::TestArgs( %args );
+}
+
+sub Run
+{
+    my $self = shift;
+    my $objs = RT::Tickets->new( $RT::SystemUser );
+    $objs->{'allow_deleted_search'} = 1;
+    if( $self->{'opt'}{'status'} ) {
+        $objs->LimitStatus( VALUE => $self->{'opt'}{'status'} );
+    }
+    if( $self->{'opt'}{'queue'} ) {
+        $objs->LimitQueue( VALUE => $self->{'opt'}{'queue'} );
+    }
+    if( $self->{'opt'}{'updated_before'} ) {
+        $objs->LimitLastUpdated( OPERATOR => '<',
+                        VALUE => $self->{'opt'}{'updated_before'},
+                      );
+    }
+    if( $self->{'opt'}{'limit'} ) {
+        $objs->RowsPerPage( $self->{'opt'}{'limit'} );
+    }
+    $objs->OrderByCols( { FIELD => 'id', ORDER => 'ASC' } );
+    return (1, $objs);
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Users.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Plugin/Users.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,142 @@
+package RT::Shredder::Plugin::Users;
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(RT::Shredder::Plugin::Base);
+
+=head1 NAME
+
+RT::Shredder::Plugin::Users - search plugin for wiping users.
+
+=cut
+
+sub Type { return 'search' }
+
+=head1 ARGUMENTS
+
+=head2 status - string
+
+Status argument allow you to limit result set to C<disabled>,
+C<enabled> or C<any> users.
+B<< Default value is C<disabled>. >>
+
+=head2 name - mask
+
+User name mask.
+
+=head2 email - mask
+
+Email address mask.
+
+=head2 replace_relations - user identifier
+
+When you delete user there is could be minor links to him in RT DB.
+This option allow you to replace this links with link to other user.
+This links are Creator and LastUpdatedBy, but NOT any watcher roles,
+this mean that if user is watcher(Requestor, Owner,
+Cc or AdminCc) of the ticket or queue then link would be deleted.
+
+This argument could be user id or name.
+
+=cut
+
+sub SupportArgs
+{
+    return $_[0]->SUPER::SupportArgs,
+           qw(status name email replace_relations);
+}
+
+sub TestArgs
+{
+    my $self = shift;
+    my %args = @_;
+    if( $args{'status'} ) {
+        unless( $args{'status'} =~ /^(disabled|enabled|any)$/i ) {
+            return (0, "Status '$args{'status'}' is unsupported.");
+        }
+    } else {
+        $args{'status'} = 'disabled';
+    }
+    if( $args{'email'} ) {
+        unless( $args{'email'} =~ /^[\w\.@?*]+$/ ) {
+            return (0, "Invalid characters in email '$args{'email'}'");
+        }
+        $args{'email'} = $self->ConvertMaskToSQL( $args{'email'} );
+    }
+    if( $args{'name'} ) {
+        unless( $args{'name'} =~ /^[\w?*]+$/ ) {
+            return (0, "Invalid characters in name '$args{'name'}'");
+        }
+        $args{'name'} = $self->ConvertMaskToSQL( $args{'name'} );
+    }
+    if( $args{'replace_relations'} ) {
+        my $uid = $args{'replace_relations'};
+        my $user = RT::User->new( $RT::SytemUser );
+        $user->Load( $uid );
+        unless( $user->id ) {
+            return (0, "Couldn't load user '$uid'" );
+        }
+        $args{'replace_relations'} = $user->id;
+    }
+    return $self->SUPER::TestArgs( %args );
+}
+
+sub Run
+{
+    my $self = shift;
+    my %args = ( Shredder => undef, @_ );
+    my $objs = RT::Users->new( $RT::SystemUser );
+    if( $self->{'opt'}{'status'} ) {
+        my $s = $self->{'opt'}{'status'};
+        if( $s eq 'any' ) {
+            $objs->{'find_disabled_rows'} = 1;
+        } elsif( $s eq 'disabled' ) {
+            $objs->{'find_disabled_rows'} = 1;
+            $objs->Limit( ALIAS => $objs->PrincipalsAlias,
+                      FIELD    => 'Disabled',
+                      OPERATOR => '!=',
+                      VALUE    => '0',
+                    );
+        } else {
+            $objs->LimitToEnabled;
+        }
+    }
+    if( $self->{'opt'}{'email'} ) {
+        $objs->Limit( FIELD => 'EmailAddress',
+                  OPERATOR => 'MATCHES',
+                  VALUE => $self->{'opt'}{'email'},
+                );
+    }
+    if( $self->{'opt'}{'name'} ) {
+        $objs->Limit( FIELD => 'Name',
+                  OPERATOR => 'MATCHES',
+                  VALUE => $self->{'opt'}{'name'},
+                );
+    }
+    if( $self->{'opt'}{'limit'} ) {
+        $objs->RowsPerPage( $self->{'opt'}{'limit'} );
+    }
+    return (1, $objs);
+}
+
+sub SetResolvers
+{
+    my $self = shift;
+    my %args = ( Shredder => undef, @_ );
+
+    if( $self->{'opt'}{'replace_relations'} ) {
+        my $uid = $self->{'opt'}{'replace_relations'};
+        my $resolver = sub {
+            my %args = (@_);
+            my $t =    $args{'TargetObject'};
+            foreach my $method ( qw(Creator LastUpdatedBy) ) {
+                next unless $t->_Accessible( $method => 'read' );
+                $t->__Set( Field => $method, Value => $uid );
+            }
+        };
+        $args{'Shredder'}->PutResolver( BaseClass => 'RT::User', Code => $resolver );
+    }
+    return (1);
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Principal.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Principal.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,79 @@
+use RT::Principal ();
+package RT::Principal;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Exceptions;
+use RT::Shredder::Constants;
+use RT::Shredder::Dependencies;
+
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Group or User
+# Could be wiped allready
+    my $obj = $self->Object;
+    if( defined $obj->id ) {
+        push( @$list, $obj );
+    }
+
+# Access Control List
+    my $objs = RT::ACL->new( $self->CurrentUser );
+    $objs->Limit(
+            FIELD => 'PrincipalId',
+            OPERATOR        => '=',
+            VALUE           => $self->Id
+           );
+    push( @$list, $objs );
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    my $obj = $self->Object;
+    if( defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related ". $self->Type ." #". $self->id ." object";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Queue.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Queue.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,53 @@
+use RT::Queue ();
+package RT::Queue;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Tickets
+    my $objs = RT::Tickets->new( $self->CurrentUser );
+    $objs->{'allow_deleted_search'} = 1;
+    $objs->Limit( FIELD => 'Queue', VALUE => $self->Id );
+    push( @$list, $objs );
+
+# Queue role groups( Cc, AdminCc )
+    $objs = RT::Groups->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'Domain', VALUE => 'RT::Queue-Role' );
+    $objs->Limit( FIELD => 'Instance', VALUE => $self->Id );
+    push( @$list, $objs );
+
+# Templates
+    $objs = $self->Templates;
+    push( @$list, $objs );
+
+# Custom Fields
+    $objs = RT::CustomFields->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'Queue', VALUE => $self->id );
+    push( @$list, $objs );
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__DependsOn( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Record.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Record.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,225 @@
+use RT::Record ();
+package RT::Record;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+
+=head2 _AsString
+
+Returns string in format ClassName-ObjectId.
+
+=cut
+
+sub _AsString { return ref($_[0]) ."-". $_[0]->id }
+
+=head2 _AsInsertQuery
+
+Returns INSERT query string that duplicates current record and
+can be used to insert record back into DB after delete.
+
+=cut
+
+sub _AsInsertQuery
+{
+    my $self = shift;
+
+    my $dbh = $RT::Handle->dbh;
+
+    my $res = "INSERT INTO ". $dbh->quote_identifier( $self->Table );
+    my $values = $self->{'values'};
+    $res .= "(". join( ",", map { $dbh->quote_identifier( $_ ) } sort keys %$values ) .")";
+    $res .= " VALUES";
+    $res .= "(". join( ",", map { $dbh->quote( $values->{$_} ) } sort keys %$values ) .")";
+    $res .= ";";
+
+    return $res;
+}
+
+sub BeforeWipeout { return 1 }
+
+=head2 Dependencies
+
+Returns L<RT::Shredder::Dependencies> object.
+
+=cut
+
+sub Dependencies
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Flags => DEPENDS_ON,
+            @_,
+           );
+
+    unless( $self->id ) {
+        RT::Shredder::Exception->throw('Object is not loaded');
+    }
+
+    my $deps = RT::Shredder::Dependencies->new();
+    if( $args{'Flags'} & DEPENDS_ON ) {
+        $self->__DependsOn( %args, Dependencies => $deps );
+    }
+    if( $args{'Flags'} & RELATES ) {
+        $self->__Relates( %args, Dependencies => $deps );
+    }
+    return $deps;
+}
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Object custom field values
+    my $objs = $self->CustomFieldValues;
+    $objs->{'find_expired_rows'} = 1;
+    push( @$list, $objs );
+
+# Object attributes
+    $objs = $self->Attributes;
+    push( @$list, $objs );
+
+# Transactions
+    $objs = RT::Transactions->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
+    $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
+    push( @$list, $objs );
+
+# Links
+    if ( $self->can('_Links') ) {
+        # XXX: We don't use Links->Next as it's dies when object
+        #      is linked to object that doesn't exist
+        #      also, ->Next skip links to deleted tickets :(
+        foreach ( qw(Base Target) ) {
+            my $objs = $self->_Links( $_ );
+            $objs->_DoSearch;
+            push @$list, $objs->ItemsArrayRef;
+        }
+    }
+
+# ACE records
+    $objs = RT::ACL->new( $self->CurrentUser );
+    $objs->LimitToObject( $self );
+    push( @$list, $objs );
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return;
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    if( $self->_Accessible( 'Creator', 'read' ) ) {
+        my $obj = RT::Principal->new( $self->CurrentUser );
+        $obj->Load( $self->Creator );
+
+        if( $obj && defined $obj->id ) {
+            push( @$list, $obj );
+        } else {
+            my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+            $self = $rec->{'Object'};
+            $rec->{'State'} |= INVALID;
+            push @{ $rec->{'Description'} },
+                "Have no related User(Creator) #". $self->Creator ." object";
+        }
+    }
+
+    if( $self->_Accessible( 'LastUpdatedBy', 'read' ) ) {
+        my $obj = RT::Principal->new( $self->CurrentUser );
+        $obj->Load( $self->LastUpdatedBy );
+
+        if( $obj && defined $obj->id ) {
+            push( @$list, $obj );
+        } else {
+            my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+            $self = $rec->{'Object'};
+            $rec->{'State'} |= INVALID;
+            push @{ $rec->{'Description'} },
+                "Have no related User(LastUpdatedBy) #". $self->LastUpdatedBy ." object";
+        }
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+
+    # cause of this $self->SUPER::__Relates should be called last
+    # in overridden subs
+    my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+    $rec->{'State'} |= VALID unless( $rec->{'State'} & INVALID );
+
+    return;
+}
+
+# implement proxy method because some RT classes
+# override Delete method
+sub __Wipeout
+{
+    my $self = shift;
+    my $msg = $self->_AsString ." wiped out";
+    $self->SUPER::Delete;
+    $RT::Logger->warning( $msg );
+    return;
+}
+
+sub ValidateRelations
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            @_
+           );
+    unless( $args{'Shredder'} ) {
+        $args{'Shredder'} = new RT::Shredder();
+    }
+
+    my $rec = $args{'Shredder'}->PutObject( Object => $self );
+    return if( $rec->{'State'} & VALID );
+    $self = $rec->{'Object'};
+
+    $self->_ValidateRelations( %args, Flags => RELATES );
+    $rec->{'State'} |= VALID unless( $rec->{'State'} & INVALID );
+
+    return;
+}
+
+sub _ValidateRelations
+{
+    my $self = shift;
+    my %args = ( @_ );
+
+    my $deps = $self->Dependencies( %args );
+
+    $deps->ValidateRelations( %args );
+
+    return;
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Scrip.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Scrip.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,82 @@
+use RT::Scrip ();
+package RT::Scrip;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# No dependencies that should be deleted with record
+# Scrip actions and conditions should be exported in feature with it.
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Queue
+    my $obj = $self->QueueObj;
+    if( defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Queue #". $self->id ." object";
+    }
+
+# Condition
+    $obj = $self->ConditionObj;
+    if( defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related ScripCondition #". $self->id ." object";
+    }
+# Action
+    $obj = $self->ActionObj;
+    if( defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related ScripAction #". $self->id ." object";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ScripAction.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ScripAction.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,52 @@
+use RT::ScripAction ();
+package RT::ScripAction;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Scrips
+    my $objs = RT::Scrips->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'ScripAction', VALUE => $self->Id );
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $objs,
+            Shredder => $args{'Shredder'}
+        );
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# TODO: Check here for exec module
+
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ScripCondition.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/ScripCondition.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,53 @@
+use RT::ScripCondition ();
+package RT::ScripCondition;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Scrips
+    my $objs = RT::Scrips->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'ScripCondition', VALUE => $self->Id );
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $objs,
+            Shredder => $args{'Shredder'}
+        );
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# TODO: Check here for exec module
+
+    return $self->SUPER::__Relates( %args );
+}
+
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Template.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Template.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,60 @@
+use RT::Template ();
+package RT::Template;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Queue
+    my $obj = $self->QueueObj;
+    if( $obj && defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Queue #". $self->id ." object";
+    }
+
+# TODO: Users(Creator, LastUpdatedBy)
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Ticket.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Ticket.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,78 @@
+use RT::Ticket ();
+package RT::Ticket;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Tickets which were merged in
+    my $objs = RT::Tickets->new( $self->CurrentUser );
+    $objs->{'allow_deleted_search'} = 1;
+    $objs->Limit( FIELD => 'EffectiveId', VALUE => $self->Id );
+    $objs->Limit( FIELD => 'id', OPERATOR => '!=', VALUE => $self->Id );
+    push( @$list, $objs );
+
+# Ticket role groups( Owner, Requestors, Cc, AdminCc )
+    $objs = RT::Groups->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'Domain', VALUE => 'RT::Ticket-Role' );
+    $objs->Limit( FIELD => 'Instance', VALUE => $self->Id );
+    push( @$list, $objs );
+
+#TODO: Users, Queues if we wish export tool
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Queue
+    my $obj = $self->QueueObj;
+    if( $obj && defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Queue #". $self->Queue ." object";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Transaction.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/Transaction.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,67 @@
+use RT::Transaction ();
+package RT::Transaction;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Attachments
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $self->Attachments,
+            Shredder => $args{'Shredder'}
+        );
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Ticket
+    my $obj = $self->TicketObj;
+    if( $obj && defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Ticket #". $self->id ." object";
+    }
+
+# TODO: Users(Creator, LastUpdatedBy)
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/User.pm
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/lib/RT/Shredder/User.pm	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,143 @@
+use RT::User ();
+package RT::User;
+
+use strict;
+use warnings;
+use warnings FATAL => 'redefine';
+
+use RT::Shredder::Constants;
+use RT::Shredder::Exceptions;
+use RT::Shredder::Dependencies;
+
+my @OBJECTS = qw(
+    Attachments
+    CachedGroupMembers
+    CustomFields
+    CustomFieldValues
+    GroupMembers
+    Groups
+    Links
+    Principals
+    Queues
+    ScripActions
+    ScripConditions
+    Scrips
+    Templates
+    ObjectCustomFieldValues
+    Tickets
+    Transactions
+    Users
+);
+
+sub __DependsOn
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Principal
+    $deps->_PushDependency(
+            BaseObject => $self,
+            Flags => DEPENDS_ON | WIPE_AFTER,
+            TargetObject => $self->PrincipalObj,
+            Shredder => $args{'Shredder'}
+        );
+
+# ACL equivalence group
+# don't use LoadACLEquivalenceGroup cause it may not exists any more
+    my $objs = RT::Groups->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'Domain', VALUE => 'ACLEquivalence' );
+    $objs->Limit( FIELD => 'Instance', VALUE => $self->Id );
+    push( @$list, $objs );
+
+# Cleanup user's membership
+    $objs = RT::GroupMembers->new( $self->CurrentUser );
+    $objs->Limit( FIELD => 'MemberId', VALUE => $self->Id );
+    push( @$list, $objs );
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+
+# TODO: Almost all objects has Creator, LastUpdatedBy and etc. fields
+# which are references on users(Principal actualy)
+    my @var_objs;
+    foreach( @OBJECTS ) {
+        my $class = "RT::$_";
+        foreach my $method ( qw(Creator LastUpdatedBy) ) {
+            my $objs = $class->new( $self->CurrentUser );
+            next unless $objs->NewItem->_Accessible( $method => 'read' );
+            $objs->Limit( FIELD => $method, VALUE => $self->id );
+            push @var_objs, $objs;
+        }
+    }
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => DEPENDS_ON | VARIABLE,
+            TargetObjects => \@var_objs,
+            Shredder => $args{'Shredder'}
+        );
+
+    return $self->SUPER::__DependsOn( %args );
+}
+
+sub __Relates
+{
+    my $self = shift;
+    my %args = (
+            Shredder => undef,
+            Dependencies => undef,
+            @_,
+           );
+    my $deps = $args{'Dependencies'};
+    my $list = [];
+
+# Principal
+    my $obj = $self->PrincipalObj;
+    if( $obj && defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related ACL equivalence Group object";
+    }
+
+    $obj = RT::Group->new( $RT::SystemUser );
+    $obj->LoadACLEquivalenceGroup( $self->PrincipalObj );
+    if( $obj && defined $obj->id ) {
+        push( @$list, $obj );
+    } else {
+        my $rec = $args{'Shredder'}->GetRecord( Object => $self );
+        $self = $rec->{'Object'};
+        $rec->{'State'} |= INVALID;
+        $rec->{'Description'} = "Have no related Principal #". $self->id ." object";
+    }
+
+    $deps->_PushDependencies(
+            BaseObject => $self,
+            Flags => RELATES,
+            TargetObjects => $list,
+            Shredder => $args{'Shredder'}
+        );
+    return $self->SUPER::__Relates( %args );
+}
+
+sub BeforeWipeout
+{
+    my $self = shift;
+    if( $self->Name =~ /^(RT_System|Nobody)$/ ) {
+        RT::Shredder::Exception::Info->throw('SystemObject');
+    }
+    return $self->SUPER::BeforeWipeout( @_ );
+}
+
+1;

Added: rt/branches/3.7-EXPERIMENTAL/sbin/rt-shredder.in
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/sbin/rt-shredder.in	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,235 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+rt-shredder - Script which wipe out tickets from RT DB
+
+=head1 SYNOPSIS
+
+  rt-shredder --plugin list
+  rt-shredder --plugin help-Tickets
+  rt-shredder --plugin 'Tickets=status,deleted;queue,general'
+
+  rt-shredder --sqldump unshred.sql --plugin ...
+  rt-shredder --force --plugin ...
+
+=head1 DESCRIPTION
+
+rt-shredder - is script that allow you to wipe out objects
+from RT DB. This script uses API that RT::Shredder module adds to RT.
+Script can be used as example of usage of the shredder API.
+
+=head1 USAGE
+
+You can use several options to control which objects script
+should delete.
+
+=head1 OPTIONS
+
+=head2 --sqldump <filename>
+
+Outputs INSERT queiries into file. This dump can be used to restore data
+after wiping out.
+
+By default creates files
+F<< <RT_home>/var/data/RT-Shredder/<ISO_date>-XXXX.sql >>
+
+=head2 --object (DEPRECATED)
+
+Option has been deprecated, use plugin C<Objects> instead.
+
+=head2 --plugin '<plugin name>[=<arg>,<val>[;<arg>,<val>]...]'
+
+You can use plugins to select RT objects with variouse conditions.
+See also --plugin list and --plugin help options.
+
+=head2 --plugin list
+
+Output list of the available plugins.
+
+=head2 --plugin help-<plugin name>
+
+Outputs help for specified plugin.
+
+=head2 --force
+
+Script doesn't ask any questions.
+
+=head1 SEE ALSO
+
+L<RT::Shredder>
+
+=cut
+
+use strict;
+use warnings FATAL => 'all';
+
+use lib ("@LOCAL_LIB_PATH@", "@RT_LIB_PATH@");
+
+use RT::Shredder ();
+use Getopt::Long qw(GetOptions);
+use File::Spec ();
+
+use RT::Shredder::Plugin ();
+# prefetch list of plugins
+our %plugins = RT::Shredder::Plugin->List;
+
+our %opt;
+parse_args();
+
+RT::Shredder::Init( %opt );
+my $shredder = new RT::Shredder;
+
+{
+    local $@;
+    my ($file, $fh) = eval { $shredder->SetFile( FileName => $opt{'sqldump'}, FromStorage => 0 ) };
+	if( $@ ) {
+        print STDERR "ERROR: Couldn't open SQL dump file: $@\n";
+        exit(1) if $opt{'sqldump'};
+
+        print STDERR "WARNING: It's strongly recommended to use '--sqldump <filename>' option\n";
+        unless( $opt{'force'} ) {
+            exit(0) unless prompt_yN( "Do you want to proceed?" );
+        }
+	} else {
+        print "SQL dump file is '$file'\n";
+    }
+}
+
+my @objs = process_plugins( $shredder );
+prompt_delete_objs( \@objs ) unless $opt{'force'};
+
+$shredder->PutObjects( Objects => $_ ) foreach @objs;
+eval { $shredder->WipeoutAll };
+if( $@ ) {
+    require RT::Shredder::Exceptions;
+    if( my $e = RT::Shredder::Exception::Info->caught ) {
+        print "\nERROR: $e\n\n";
+        exit 1;
+    }
+    die $@;
+}
+
+sub prompt_delete_objs
+{
+	my( $objs ) = @_;
+	unless( @$objs ) {
+		print "Objects list is empty, try refine search options\n";
+		exit 0;
+	}
+	my $list = "Next objects would be deleted:\n";
+	foreach my $o( @$objs ) {
+		$list .= "\t". $o->_AsString ." object\n";
+	}
+	print $list;
+	exit(0) unless prompt_yN( "Do you want to proceed?" );
+}
+
+sub prompt_yN
+{
+	my $text = shift;
+	print "$text [y/N] ";
+	unless( <STDIN> =~ /^(?:y|yes)$/i ) {
+		return 0;
+	}
+	return 1;
+}
+
+sub usage
+{
+	require RT::Shredder::POD;
+	RT::Shredder::POD::shredder_cli( $0, \*STDOUT );
+	exit 1;
+}
+
+sub parse_args
+{
+	my $tmp;
+	Getopt::Long::Configure( "pass_through" );
+	my @objs = ();
+	if( GetOptions( 'object=s' => \@objs ) && @objs ) {
+		print STDERR "Option --object had been deprecated, use plugin 'Objects' instead\n";
+        exit(1);
+	}
+
+	my @plugins = ();
+	if( GetOptions( 'plugin=s' => \@plugins ) && @plugins ) {
+		$opt{'plugin'} = \@plugins;
+		foreach my $str( @plugins ) {
+			if( $str =~ /^\s*list\s*$/ ) {
+				show_plugin_list();
+			} elsif( $str =~ /^\s*help-(\w+)\s*$/ ) {
+				show_plugin_help( $1 );
+			} elsif( $str =~ /^(\w+)(=.*)?$/ && !$plugins{$1} ) {
+				print "Couldn't find plugin '$1'\n";
+				show_plugin_list();
+			}
+		}
+	}
+
+	# other options make no sense without previouse
+	usage() unless keys %opt;
+
+	if( GetOptions( 'force' => \$tmp ) && $tmp ) {
+		$opt{'force'}++;
+	}
+	$tmp = undef;
+	if( GetOptions( 'sqldump=s' => \$tmp ) && $tmp ) {
+		$opt{'sqldump'} = $tmp;
+	}
+	return;
+}
+
+sub process_plugins
+{
+	my @res;
+	my $shredder = shift;
+	foreach my $str( @{ $opt{'plugin'} } ) {
+		my $plugin = new RT::Shredder::Plugin;
+		my( $status, $msg ) = $plugin->LoadByString( $str );
+		unless( $status ) {
+			print STDERR "Couldn't load plugin\n";
+			print STDERR "Error: $msg\n";
+			exit(1);
+		}
+		
+		my @objs = ();
+		($status, @objs) = $plugin->Run;
+		unless( $status ) {
+			print STDERR "Couldn't run plugin\n";
+			print STDERR "Error: $objs[1]\n";
+			exit(1);
+		}
+
+		($status, $msg) = $plugin->SetResolvers( Shredder => $shredder );
+		unless( $status ) {
+			print STDERR "Couldn't set conflicts resolver\n";
+			print STDERR "Error: $msg\n";
+			exit(1);
+		}
+		push @res, @objs;
+	}
+	return RT::Shredder->CastObjectsToRecords( Objects => \@res );
+}
+
+sub show_plugin_list
+{
+	print "Plugins list:\n";
+	print "\t$_\n" foreach( grep !/^Base$/, keys %plugins );
+	exit(1);
+}
+
+sub show_plugin_help
+{
+	my( $name ) = @_;
+	require RT::Shredder::POD;
+	unless( $plugins{ $name } ) {
+		print "Couldn't find plugin '$name'\n";
+		show_plugin_list();
+	}
+	RT::Shredder::POD::plugin_cli( $plugins{'Base'}, \*STDOUT, 1 );
+	RT::Shredder::POD::plugin_cli( $plugins{ $name }, \*STDOUT );
+	exit(1);
+}
+
+exit(0);

Added: rt/branches/3.7-EXPERIMENTAL/sbin/rt-validator.in
==============================================================================
--- (empty file)
+++ rt/branches/3.7-EXPERIMENTAL/sbin/rt-validator.in	Mon Jun 19 22:09:49 2006
@@ -0,0 +1,97 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+rtx-validator - Script that allow validate rt database
+
+=head1 SYNOPSIS
+
+rtx-validator -o Ticket-100
+
+=head1 DESCRIPTION
+
+=head2 OPTIONS
+
+=head3 -o, --object <name>-<id>
+
+Object(class) name and object id splitted with C<-> that should be validated.
+Option is case sensetive.
+
+=head1 SEE ALSO
+
+C<RT::Shredder>
+
+=cut
+
+
+use strict;
+use Getopt::Long;
+
+### after: use lib qw(@RT_LIB_PATH@);
+use lib qw(/opt/rt3/local/lib /opt/rt3/lib);
+
+use RT::Shredder;
+use RT::Shredder::Constants;
+RT::Shredder::Init();
+
+our %opt;
+parse_args();
+
+unless( $opt{'object'} ) {
+	usage();
+}
+
+my $obj = load_object( $opt{'object'} );
+
+my $shredder = RT::Shredder->new;
+$obj->ValidateRelations( Shredder => $shredder );
+
+foreach my $record( values %{ $shredder->{'Cache'} } ) {
+	next unless( $record->{'State'} & INVALID );
+	print STDERR $record->{'Object'}->_AsString ." is invalid\n";
+	print STDERR "\t". (ref($record->{'Description'}) ?
+			join( "\n\t", @{$record->{'Description'}} ) :
+			$record->{'Description'})
+		."\n";
+}
+
+#use Data::Dumper;
+#print Dumper( $shredder );
+
+
+
+sub usage
+{
+	print <<END;
+	usage: $0 --object <name>-<id>
+
+END
+	exit 1;
+}
+
+sub parse_args
+{
+	my $tmp;
+	Getopt::Long::Configure( "pass_through" );
+	$tmp = undef;
+	if( GetOptions( 'object=s' => \$tmp ) && $tmp ) {
+		$opt{'object'} = $tmp;
+	}
+	return;
+}
+
+sub load_object
+{
+	my $desc = shift;
+	my ($class, $id) = split /-/, $desc;
+	$class = 'RT::'. $class;
+	eval "require $class";
+	die "Couldn't load '$class' module" if $@;
+	my $obj = $class->new( $RT::SystemUser );
+	die "Couldn't construct new '$class' object" unless $obj;
+	$obj->Load( $id );
+	die "Couldn't load '$class' object by id '$id'" unless $obj->id;
+	die "Loaded object has different id" unless( $id eq $obj->id );
+	return $obj;
+}
+


More information about the Rt-commit mailing list