[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