RT 3.8.17
[freeside.git] / rt / lib / RT / Shredder.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
6 #                                          <sales@bestpractical.com>
7 #
8 # (Except where explicitly superseded by other copyright notices)
9 #
10 #
11 # LICENSE:
12 #
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
16 # from www.gnu.org.
17 #
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21 # General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28 #
29 #
30 # CONTRIBUTION SUBMISSION POLICY:
31 #
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
37 #
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
46 #
47 # END BPS TAGGED BLOCK }}}
48
49 package RT::Shredder;
50
51 use strict;
52 use warnings;
53
54
55 =head1 NAME
56
57 RT::Shredder - Permanently wipeout data from RT
58
59
60 =head1 SYNOPSIS
61
62 =head2 CLI
63
64   rt-shredder --force --plugin 'Tickets=queue,general;status,deleted'
65
66
67 =head1 DESCRIPTION
68
69 RT::Shredder is extension to RT which allows you to permanently wipeout
70 data from the RT database.  Shredder supports the wiping of almost
71 all RT objects (Tickets, Transactions, Attachments, Users...).
72
73
74 =head2 "Delete" vs "Wipeout"
75
76 RT uses the term "delete" to mean "deactivate".  To avoid confusion,
77 RT::Shredder uses the term "Wipeout" to mean "permanently erase" (or
78 what most people would think of as "delete").
79
80
81 =head2 Why do you want this?
82
83 Normally in RT, "deleting" an item simply deactivates it and makes it
84 invisible from view.  This is done to retain full history and
85 auditability of your tickets.  For most RT users this is fine and they
86 have no need of RT::Shredder.
87
88 But in some large and heavily used RT instances the database can get
89 clogged up with junk, particularly spam.  This can slow down searches
90 and bloat the size of the database.  For these users, RT::Shredder
91 allows them to completely clear the database of this unwanted junk.
92
93 An additional use of Shredder is to obliterate sensitive information
94 (passwords, credit card numbers, ...) which might have made their way
95 into RT.
96
97
98 =head2 Command line tools (CLI)
99
100 L<rt-shredder> is a program which allows you to wipe objects from
101 command line or with system tasks scheduler (cron, for example).
102 See also 'rt-shredder --help'.
103
104
105 =head2 Web based interface (WebUI)
106
107 Shredder's WebUI integrates into RT's WebUI.  You can find it in the
108 Configuration->Tools->Shredder tab.  The interface is similar to the
109 CLI and gives you the same functionality. You can find 'Shredder' link
110 at the bottom of tickets search results, so you could wipeout tickets
111 in the way similar to the bulk update.
112
113
114 =head1 DATA STORAGE AND BACKUPS
115
116 Shredder allows you to store data you wiped in files as scripts with SQL
117 commands.
118
119 =head3 Restoring from backup
120
121 Should you wipeout something you did not intend to the objects can be
122 restored by using the storage files.  These files are a simple set of
123 SQL commands to re-insert your objects into the RT database.
124
125 1) Locate the appropriate shredder SQL dump file.  In the WebUI, when
126    you use shredder, the path to the dump file is displayed.  It also
127    gives the option to download the dump file after each wipeout.  Or
128    it can be found in your C<$ShredderStoragePath>.
129
130 2) Load the shredder SQL dump into your RT database.  The details will
131    be different for each database and RT configuration, consult your
132    database manual and RT config.  For example, in MySQL...
133
134     mysql -u your_rt_user -p your_rt_database < /path/to/rt/var/data/shredder/dump.sql
135
136 That's it.i This will restore everything you'd deleted during a
137 shredding session when the file had been created.
138
139 =head1 CONFIGURATION
140
141 =head2 $RT::DependenciesLimit
142
143 Shredder stops with an error if the object has more than
144 C<$RT::DependenciesLimit> dependencies. For example: a ticket has 1000
145 transactions or a transaction has 1000 attachments. This is protection
146 from bugs in shredder from wiping out your whole database, but
147 sometimes when you have big mail loops you may hit it.
148
149 Defaults to 1000.
150
151 You can change the default value, in F<RT_SiteConfig.pm> add C<Set(
152 $DependenciesLimit, new_limit );>
153
154
155 =head2 $ShredderStoragePath
156
157 Directory containing Shredder backup dumps.
158
159 Defaults to F</path-to-RT-var-dir/data/RT-Shredder>.
160
161 You can change the default value, in F<RT_SiteConfig.pm> add C<Set(
162 $ShredderStoragePath, new_path );>  Be sure to use an absolute path.
163
164
165 =head1 INFORMATION FOR DEVELOPERS
166
167 =head2 General API
168
169 L<RT::Shredder> is an extension to RT which adds shredder methods to
170 RT objects and classes.  The API is not well documented yet, but you
171 can find usage examples in L<rt-shredder> and the
172 F<lib/t/regression/shredder/*.t> test files.
173
174 However, here is a small example that do the same action as in CLI
175 example from L</SYNOPSIS>:
176
177   use RT::Shredder;
178   RT::Shredder::Init( force => 1 );
179   my $deleted = RT::Tickets->new( $RT::SystemUser );
180   $deleted->{'allow_deleted_search'} = 1;
181   $deleted->LimitQueue( VALUE => 'general' );
182   $deleted->LimitStatus( VALUE => 'deleted' );
183   while( my $t = $deleted->Next ) {
184       $t->Wipeout;
185   }
186
187
188 =head2 RT::Shredder class' API
189
190 L<RT::Shredder> implements interfaces to objects cache, actions on the
191 objects in the cache and backups storage.
192
193 =cut
194
195 our $VERSION = '0.04';
196 use File::Spec ();
197
198
199 BEGIN {
200 # I can't use 'use lib' here since it breakes tests
201 # because test suite uses old RT::Shredder setup from
202 # RT lib path
203
204 ### after:     push @INC, qw(@RT_LIB_PATH@);
205     push @INC, qw(/opt/rt3/local/lib /opt/rt3/lib);
206     use RT::Shredder::Constants;
207     use RT::Shredder::Exceptions;
208
209     require RT;
210
211     require RT::Shredder::Record;
212
213     require RT::Shredder::ACE;
214     require RT::Shredder::Attachment;
215     require RT::Shredder::CachedGroupMember;
216     require RT::Shredder::CustomField;
217     require RT::Shredder::CustomFieldValue;
218     require RT::Shredder::GroupMember;
219     require RT::Shredder::Group;
220     require RT::Shredder::Link;
221     require RT::Shredder::Principal;
222     require RT::Shredder::Queue;
223     require RT::Shredder::Scrip;
224     require RT::Shredder::ScripAction;
225     require RT::Shredder::ScripCondition;
226     require RT::Shredder::Template;
227     require RT::Shredder::ObjectCustomFieldValue;
228     require RT::Shredder::Ticket;
229     require RT::Shredder::Transaction;
230     require RT::Shredder::User;
231 }
232
233 our @SUPPORTED_OBJECTS = qw(
234     ACE
235     Attachment
236     CachedGroupMember
237     CustomField
238     CustomFieldValue
239     GroupMember
240     Group
241     Link
242     Principal
243     Queue
244     Scrip
245     ScripAction
246     ScripCondition
247     Template
248     ObjectCustomFieldValue
249     Ticket
250     Transaction
251     User
252 );
253
254 =head3 GENERIC
255
256 =head4 Init
257
258     RT::Shredder::Init( %default_options );
259
260 C<RT::Shredder::Init()> should be called before creating an
261 RT::Shredder object.  It iniitalizes RT and loads the RT
262 configuration.
263
264 %default_options are passed to every C<<RT::Shredder->new>> call.
265
266 =cut
267
268 our %opt = ();
269
270 sub Init
271 {
272     %opt = @_;
273     RT::LoadConfig();
274     RT::Init();
275 }
276
277 =head4 new
278
279   my $shredder = RT::Shredder->new(%options);
280
281 Construct a new RT::Shredder object.
282
283 There currently are no %options.
284
285 =cut
286
287 sub new
288 {
289     my $proto = shift;
290     my $self = bless( {}, ref $proto || $proto );
291     $self->_Init( @_ );
292     return $self;
293 }
294
295 sub _Init
296 {
297     my $self = shift;
298     $self->{'opt'}          = { %opt, @_ };
299     $self->{'cache'}        = {};
300     $self->{'resolver'}     = {};
301     $self->{'dump_plugins'} = [];
302 }
303
304 =head4 CastObjectsToRecords( Objects => undef )
305
306 Cast objects to the C<RT::Record> objects or its ancesstors.
307 Objects can be passed as SCALAR (format C<< <class>-<id> >>),
308 ARRAY, C<RT::Record> ancesstors or C<RT::SearchBuilder> ancesstor.
309
310 Most methods that takes C<Objects> argument use this method to
311 cast argument value to list of records.
312
313 Returns an array of records.
314
315 For example:
316
317     my @objs = $shredder->CastObjectsToRecords(
318         Objects => [             # ARRAY reference
319             'RT::Attachment-10', # SCALAR or SCALAR reference
320             $tickets,            # RT::Tickets object (isa RT::SearchBuilder)
321             $user,               # RT::User object (isa RT::Record)
322         ],
323     );
324
325 =cut
326
327 sub CastObjectsToRecords
328 {
329     my $self = shift;
330     my %args = ( Objects => undef, @_ );
331
332     my @res;
333     my $targets = delete $args{'Objects'};
334     unless( $targets ) {
335         RT::Shredder::Exception->throw( "Undefined Objects argument" );
336     }
337
338     if( UNIVERSAL::isa( $targets, 'RT::SearchBuilder' ) ) {
339         #XXX: try to use ->_DoSearch + ->ItemsArrayRef in feature
340         #     like we do in Record with links, but change only when
341         #     more tests would be available
342         while( my $tmp = $targets->Next ) { push @res, $tmp };
343     } elsif ( UNIVERSAL::isa( $targets, 'RT::Record' ) ) {
344         push @res, $targets;
345     } elsif ( UNIVERSAL::isa( $targets, 'ARRAY' ) ) {
346         foreach( @$targets ) {
347             push @res, $self->CastObjectsToRecords( Objects => $_ );
348         }
349     } elsif ( UNIVERSAL::isa( $targets, 'SCALAR' ) || !ref $targets ) {
350         $targets = $$targets if ref $targets;
351         my ($class, $id) = split /-/, $targets;
352         RT::Shredder::Exception->throw( "Unsupported class $class" )
353               unless $class =~ /^\w+(::\w+)*$/;
354         $class = 'RT::'. $class unless $class =~ /^RTx?::/i;
355         eval "require $class";
356         die "Couldn't load '$class' module" if $@;
357         my $obj = $class->new( $RT::SystemUser );
358         die "Couldn't construct new '$class' object" unless $obj;
359         $obj->Load( $id );
360         unless ( $obj->id ) {
361             $RT::Logger->error( "Couldn't load '$class' object with id '$id'" );
362             RT::Shredder::Exception::Info->throw( 'CouldntLoadObject' );
363         }
364         die "Loaded object has different id" unless( $id eq $obj->id );
365         push @res, $obj;
366     } else {
367         RT::Shredder::Exception->throw( "Unsupported type ". ref $targets );
368     }
369     return @res;
370 }
371
372 =head3 OBJECTS CACHE
373
374 =head4 PutObjects( Objects => undef )
375
376 Puts objects into cache.
377
378 Returns array of the cache entries.
379
380 See C<CastObjectsToRecords> method for supported types of the C<Objects>
381 argument.
382
383 =cut
384
385 sub PutObjects
386 {
387     my $self = shift;
388     my %args = ( Objects => undef, @_ );
389
390     my @res;
391     for( $self->CastObjectsToRecords( Objects => delete $args{'Objects'} ) ) {
392         push @res, $self->PutObject( %args, Object => $_ )
393     }
394
395     return @res;
396 }
397
398 =head4 PutObject( Object => undef )
399
400 Puts record object into cache and returns its cache entry.
401
402 B<NOTE> that this method support B<only C<RT::Record> object or its ancesstor
403 objects>, if you want put mutliple objects or objects represented by different
404 classes then use C<PutObjects> method instead.
405
406 =cut
407
408 sub PutObject
409 {
410     my $self = shift;
411     my %args = ( Object => undef, @_ );
412
413     my $obj = $args{'Object'};
414     unless( UNIVERSAL::isa( $obj, 'RT::Record' ) ) {
415         RT::Shredder::Exception->throw( "Unsupported type '". (ref $obj || $obj || '(undef)')."'" );
416     }
417
418     my $str = $obj->_AsString;
419     return ($self->{'cache'}->{ $str } ||= { State => ON_STACK, Object => $obj } );
420 }
421
422 =head4 GetObject, GetState, GetRecord( String => ''| Object => '' )
423
424 Returns record object from cache, cache entry state or cache entry accordingly.
425
426 All three methods takes C<String> (format C<< <class>-<id> >>) or C<Object> argument.
427 C<String> argument has more priority than C<Object> so if it's not empty then methods
428 leave C<Object> argument unchecked.
429
430 You can read about possible states and their meanings in L<RT::Shredder::Constants> docs.
431
432 =cut
433
434 sub _ParseRefStrArgs
435 {
436     my $self = shift;
437     my %args = (
438         String => '',
439         Object => undef,
440         @_
441     );
442     if( $args{'String'} && $args{'Object'} ) {
443         require Carp;
444         Carp::croak( "both String and Object args passed" );
445     }
446     return $args{'String'} if $args{'String'};
447     return $args{'Object'}->_AsString if UNIVERSAL::can($args{'Object'}, '_AsString' );
448     return '';
449 }
450
451 sub GetObject { return (shift)->GetRecord( @_ )->{'Object'} }
452 sub GetState { return (shift)->GetRecord( @_ )->{'State'} }
453 sub GetRecord
454 {
455     my $self = shift;
456     my $str = $self->_ParseRefStrArgs( @_ );
457     return $self->{'cache'}->{ $str };
458 }
459
460 =head3 Dependencies resolvers
461
462 =head4 PutResolver, GetResolvers and ApplyResolvers
463
464 TODO: These methods have no documentation.
465
466 =cut
467
468 sub PutResolver
469 {
470     my $self = shift;
471     my %args = (
472         BaseClass => '',
473         TargetClass => '',
474         Code => undef,
475         @_,
476     );
477     unless( UNIVERSAL::isa( $args{'Code'} => 'CODE' ) ) {
478         die "Resolver '$args{Code}' is not code reference";
479     }
480
481     my $resolvers = (
482         (
483             $self->{'resolver'}->{ $args{'BaseClass'} } ||= {}
484         )->{  $args{'TargetClass'} || '' } ||= []
485     );
486     unshift @$resolvers, $args{'Code'};
487     return;
488 }
489
490 sub GetResolvers
491 {
492     my $self = shift;
493     my %args = (
494         BaseClass => '',
495         TargetClass => '',
496         @_,
497     );
498
499     my @res;
500     if( $args{'TargetClass'} && exists $self->{'resolver'}->{ $args{'BaseClass'} }->{ $args{'TargetClass'} } ) {
501         push @res, @{ $self->{'resolver'}->{ $args{'BaseClass'} }->{ $args{'TargetClass'} || '' } };
502     }
503     if( exists $self->{'resolver'}->{ $args{'BaseClass'} }->{ '' } ) {
504         push @res, @{ $self->{'resolver'}->{ $args{'BaseClass'} }->{''} };
505     }
506
507     return @res;
508 }
509
510 sub ApplyResolvers
511 {
512     my $self = shift;
513     my %args = ( Dependency => undef, @_ );
514     my $dep = $args{'Dependency'};
515
516     my @resolvers = $self->GetResolvers(
517         BaseClass   => $dep->BaseClass,
518         TargetClass => $dep->TargetClass,
519     );
520
521     unless( @resolvers ) {
522         RT::Shredder::Exception::Info->throw(
523             tag   => 'NoResolver',
524             error => "Couldn't find resolver for dependency '". $dep->AsString ."'",
525         );
526     }
527     $_->(
528         Shredder     => $self,
529         BaseObject   => $dep->BaseObject,
530         TargetObject => $dep->TargetObject,
531     ) foreach @resolvers;
532
533     return;
534 }
535
536 sub WipeoutAll
537 {
538     my $self = $_[0];
539
540     while ( my ($k, $v) = each %{ $self->{'cache'} } ) {
541         next if $v->{'State'} & (WIPED | IN_WIPING);
542         $self->Wipeout( Object => $v->{'Object'} );
543     }
544 }
545
546 sub Wipeout
547 {
548     my $self = shift;
549     my $mark;
550     eval {
551         die "Couldn't begin transaction" unless $RT::Handle->BeginTransaction;
552         $mark = $self->PushDumpMark or die "Couldn't get dump mark";
553         $self->_Wipeout( @_ );
554         $self->PopDumpMark( Mark => $mark );
555         die "Couldn't commit transaction" unless $RT::Handle->Commit;
556     };
557     if( $@ ) {
558         $RT::Handle->Rollback('force');
559         $self->RollbackDumpTo( Mark => $mark ) if $mark;
560         die $@ if RT::Shredder::Exception::Info->caught;
561         die "Couldn't wipeout object: $@";
562     }
563 }
564
565 sub _Wipeout
566 {
567     my $self = shift;
568     my %args = ( CacheRecord => undef, Object => undef, @_ );
569
570     my $record = $args{'CacheRecord'};
571     $record = $self->PutObject( Object => $args{'Object'} ) unless $record;
572     return if $record->{'State'} & (WIPED | IN_WIPING);
573
574     $record->{'State'} |= IN_WIPING;
575     my $object = $record->{'Object'};
576
577     $self->DumpObject( Object => $object, State => 'before any action' );
578
579     unless( $object->BeforeWipeout ) {
580         RT::Shredder::Exception->throw( "BeforeWipeout check returned error" );
581     }
582
583     my $deps = $object->Dependencies( Shredder => $self );
584     $deps->List(
585         WithFlags => DEPENDS_ON | VARIABLE,
586         Callback  => sub { $self->ApplyResolvers( Dependency => $_[0] ) },
587     );
588     $self->DumpObject( Object => $object, State => 'after resolvers' );
589
590     $deps->List(
591         WithFlags    => DEPENDS_ON,
592         WithoutFlags => WIPE_AFTER | VARIABLE,
593         Callback     => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) },
594     );
595     $self->DumpObject( Object => $object, State => 'after wiping dependencies' );
596
597     $object->__Wipeout;
598     $record->{'State'} |= WIPED; delete $record->{'Object'};
599     $self->DumpObject( Object => $object, State => 'after wipeout' );
600
601     $deps->List(
602         WithFlags => DEPENDS_ON | WIPE_AFTER,
603         WithoutFlags => VARIABLE,
604         Callback => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) },
605     );
606     $self->DumpObject( Object => $object, State => 'after late dependencies' );
607
608     return;
609 }
610
611 sub ValidateRelations
612 {
613     my $self = shift;
614     my %args = ( @_ );
615
616     foreach my $record( values %{ $self->{'cache'} } ) {
617         next if( $record->{'State'} & VALID );
618         $record->{'Object'}->ValidateRelations( Shredder => $self );
619     }
620 }
621
622 =head3 Data storage and backups
623
624 =head4 GetFileName( FileName => '<ISO DATETIME>-XXXX.sql', FromStorage => 1 )
625
626 Takes desired C<FileName> and flag C<FromStorage> then translate file name to absolute
627 path by next rules:
628
629 * Default value of the C<FileName> option is C<< <ISO DATETIME>-XXXX.sql >>;
630
631 * 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 free value;
632
633 * if C<FileName> has C<%T> then it would be replaced with the current date and time in the C<YYYY-MM-DDTHH:MM:SS> format. Note that using C<%t> may still generate not unique names, using C<XXXX> recomended.
634
635 * if C<FromStorage> argument is true (default behaviour) then result path would always be relative to C<StoragePath>;
636
637 * if C<FromStorage> argument is false then result would be relative to the current dir unless it's already absolute path.
638
639 Returns an absolute path of the file.
640
641 Examples:
642     # file from storage with default name format
643     my $fname = $shredder->GetFileName;
644
645     # file from storage with custom name format
646     my $fname = $shredder->GetFileName( FileName => 'shredder-XXXX.backup' );
647
648     # file with path relative to the current dir
649     my $fname = $shredder->GetFileName(
650         FromStorage => 0,
651         FileName => 'backups/shredder.sql',
652     );
653
654     # file with absolute path
655     my $fname = $shredder->GetFileName(
656         FromStorage => 0,
657         FileName => '/var/backups/shredder-XXXX.sql'
658     );
659
660 =cut
661
662 sub GetFileName
663 {
664     my $self = shift;
665     my %args = ( FileName => '', FromStorage => 1, @_ );
666
667     # default value
668     my $file = $args{'FileName'} || '%t-XXXX.sql';
669     if( $file =~ /\%t/i ) {
670         require POSIX;
671         my $date_time = POSIX::strftime( "%Y%m%dT%H%M%S", gmtime );
672         $file =~ s/\%t/$date_time/gi;
673     }
674
675     # convert to absolute path
676     if( $args{'FromStorage'} ) {
677         $file = File::Spec->catfile( $self->StoragePath, $file );
678     } elsif( !File::Spec->file_name_is_absolute( $file ) ) {
679         $file = File::Spec->rel2abs( $file );
680     }
681
682     # check mask
683     if( $file =~ /XXXX[^\/\\]*$/ ) {
684         my( $tmp, $i ) = ( $file, 0 );
685         do {
686             $i++;
687             $tmp = $file;
688             $tmp =~ s/XXXX([^\/\\]*)$/sprintf("%04d", $i).$1/e;
689         } while( -e $tmp && $i < 9999 );
690         $file = $tmp;
691     }
692
693     if( -f $file ) {
694         unless( -w _ ) {
695             die "File '$file' exists, but is read-only";
696         }
697     } elsif( !-e _ ) {
698         unless( File::Spec->file_name_is_absolute( $file ) ) {
699             $file = File::Spec->rel2abs( $file );
700         }
701
702         # check base dir
703         my $dir = File::Spec->join( (File::Spec->splitpath( $file ))[0,1] );
704         unless( -e $dir && -d _) {
705             die "Base directory '$dir' for file '$file' doesn't exist";
706         }
707         unless( -w $dir ) {
708             die "Base directory '$dir' is not writable";
709         }
710     } else {
711         die "'$file' is not regular file";
712     }
713
714     return $file;
715 }
716
717 =head4 StoragePath
718
719 Returns an absolute path to the storage dir.  See
720 L<CONFIGURATION/$ShredderStoragePath>.
721
722 See also description of the L</GetFileName> method.
723
724 =cut
725
726 sub StoragePath
727 {
728     return scalar( RT->Config->Get('ShredderStoragePath') )
729         || File::Spec->catdir( $RT::VarPath, qw(data RT-Shredder) );
730 }
731
732 my %active_dump_state = ();
733 sub AddDumpPlugin {
734     my $self = shift;
735     my %args = ( Object => undef, Name => 'SQLDump', Arguments => undef, @_ );
736
737     my $plugin = $args{'Object'};
738     unless ( $plugin ) {
739         require RT::Shredder::Plugin;
740         $plugin = RT::Shredder::Plugin->new;
741         my( $status, $msg ) = $plugin->LoadByName( $args{'Name'} );
742         die "Couldn't load dump plugin: $msg\n" unless $status;
743     }
744     die "Plugin is not of correct type" unless lc $plugin->Type eq 'dump';
745
746     if ( my $pargs = $args{'Arguments'} ) {
747         my ($status, $msg) = $plugin->TestArgs( %$pargs );
748         die "Couldn't set plugin args: $msg\n" unless $status;
749     }
750
751     my @applies_to = $plugin->AppliesToStates;
752     die "Plugin doesn't apply to any state" unless @applies_to;
753     $active_dump_state{ lc $_ } = 1 foreach @applies_to;
754
755     push @{ $self->{'dump_plugins'} }, $plugin;
756
757     return $plugin;
758 }
759
760 sub DumpObject {
761     my $self = shift;
762     my %args = (Object => undef, State => undef, @_);
763     die "No state passed" unless $args{'State'};
764     return unless $active_dump_state{ lc $args{'State'} };
765
766     foreach (@{ $self->{'dump_plugins'} }) {
767         next unless grep lc $args{'State'} eq lc $_, $_->AppliesToStates;
768         my ($state, $msg) = $_->Run( %args );
769         die "Couldn't run plugin: $msg" unless $state;
770     }
771 }
772
773 { my $mark = 1; # XXX: integer overflows?
774 sub PushDumpMark {
775     my $self = shift;
776     $mark++;
777     foreach (@{ $self->{'dump_plugins'} }) {
778         my ($state, $msg) = $_->PushMark( Mark => $mark );
779         die "Couldn't push mark: $msg" unless $state;
780     }
781     return $mark;
782 }
783 sub PopDumpMark {
784     my $self = shift;
785     foreach (@{ $self->{'dump_plugins'} }) {
786         my ($state, $msg) = $_->PushMark( @_ );
787         die "Couldn't pop mark: $msg" unless $state;
788     }
789 }
790 sub RollbackDumpTo {
791     my $self = shift;
792     foreach (@{ $self->{'dump_plugins'} }) {
793         my ($state, $msg) = $_->RollbackTo( @_ );
794         die "Couldn't rollback to mark: $msg" unless $state;
795     }
796 }
797 }
798
799 1;
800 __END__
801
802 =head1 NOTES
803
804 =head2 Database transactions support
805
806 Since 0.03_01 RT::Shredder uses database transactions and should be
807 much safer to run on production servers.
808
809 =head2 Foreign keys
810
811 Mainstream RT doesn't use FKs, but at least I posted DDL script that creates them
812 in mysql DB, note that if you use FKs then this two valid keys don't allow delete
813 Tickets because of bug in MySQL:
814
815   ALTER TABLE Tickets ADD FOREIGN KEY (EffectiveId) REFERENCES Tickets(id);
816   ALTER TABLE CachedGroupMembers ADD FOREIGN KEY (Via) REFERENCES CachedGroupMembers(id);
817
818 L<http://bugs.mysql.com/bug.php?id=4042>
819
820 =head1 BUGS AND HOW TO CONTRIBUTE
821
822 We need your feedback in all cases: if you use it or not,
823 is it works for you or not.
824
825 =head2 Testing
826
827 Don't skip C<make test> step while install and send me reports if it's fails.
828 Add your own tests, it's easy enough if you've writen at list one perl script
829 that works with RT. Read more about testing in F<t/utils.pl>.
830
831 =head2 Reporting
832
833 Send reports to L</AUTHOR> or to the RT mailing lists.
834
835 =head2 Documentation
836
837 Many bugs in the docs: insanity, spelling, gramar and so on.
838 Patches are wellcome.
839
840 =head2 Todo
841
842 Please, see Todo file, it has some technical notes
843 about what I plan to do, when I'll do it, also it
844 describes some problems code has.
845
846 =head2 Repository
847
848 Since RT-3.7 shredder is a part of the RT distribution.
849 Versions of the RTx::Shredder extension could
850 be downloaded from the CPAN. Those work with older
851 RT versions or you can find repository at
852 L<https://opensvn.csie.org/rtx_shredder>
853
854 =head1 AUTHOR
855
856     Ruslan U. Zakirov <Ruslan.Zakirov@gmail.com>
857
858 =head1 COPYRIGHT
859
860 This program is free software; you can redistribute
861 it and/or modify it under the same terms as Perl itself.
862
863 The full text of the license can be found in the
864 Perl distribution.
865
866 =head1 SEE ALSO
867
868 L<rt-shredder>, L<rt-validator>
869
870 =cut