Dev to 4.0.11
[usit-rt.git] / 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
56 =head1 NAME
57
58 RT::Shredder - Permanently wipeout data from RT
59
60
61 =head1 SYNOPSIS
62
63 =head2 CLI
64
65   rt-shredder --force --plugin 'Tickets=query,Queue="General" and Status="deleted"'
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 $DependenciesLimit
142
143 Shredder stops with an error if the object has more than
144 C<$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.  To change this (for example, to 10000) add the
150 following to your F<RT_SiteConfig.pm>:
151
152     Set( $DependenciesLimit, 10_000 );>
153
154
155 =head2 $ShredderStoragePath
156
157 Directory containing Shredder backup dumps; defaults to
158 F</opt/rt4/var/data/RT-Shredder> (assuming an /opt/rt4 installation).
159
160 To change this (for example, to /some/backup/path) add the following to
161 your F<RT_SiteConfig.pm>:
162
163     Set( $ShredderStoragePath, "/some/backup/path" );>
164
165 Be sure to specify an absolute path.
166
167
168 =head1 INFORMATION FOR DEVELOPERS
169
170 =head2 General API
171
172 L<RT::Shredder> is an extension to RT which adds shredder methods to
173 RT objects and classes.  The API is not well documented yet, but you
174 can find usage examples in L<rt-shredder> and the
175 F<lib/t/regression/shredder/*.t> test files.
176
177 However, here is a small example that do the same action as in CLI
178 example from L</SYNOPSIS>:
179
180   use RT::Shredder;
181   RT::Shredder::Init( force => 1 );
182   my $deleted = RT::Tickets->new( RT->SystemUser );
183   $deleted->{'allow_deleted_search'} = 1;
184   $deleted->LimitQueue( VALUE => 'general' );
185   $deleted->LimitStatus( VALUE => 'deleted' );
186   while( my $t = $deleted->Next ) {
187       $t->Wipeout;
188   }
189
190
191 =head2 RT::Shredder class' API
192
193 L<RT::Shredder> implements interfaces to objects cache, actions on the
194 objects in the cache and backups storage.
195
196 =cut
197
198 our $VERSION = '0.04';
199 use File::Spec ();
200
201
202 BEGIN {
203 # I can't use 'use lib' here since it breakes tests
204 # because test suite uses old RT::Shredder setup from
205 # RT lib path
206
207 ### after:     push @INC, qw(@RT_LIB_PATH@);
208     use RT::Shredder::Constants;
209     use RT::Shredder::Exceptions;
210
211     require RT;
212
213     require RT::Shredder::Record;
214
215     require RT::Shredder::ACE;
216     require RT::Shredder::Attachment;
217     require RT::Shredder::CachedGroupMember;
218     require RT::Shredder::CustomField;
219     require RT::Shredder::CustomFieldValue;
220     require RT::Shredder::GroupMember;
221     require RT::Shredder::Group;
222     require RT::Shredder::Link;
223     require RT::Shredder::Principal;
224     require RT::Shredder::Queue;
225     require RT::Shredder::Scrip;
226     require RT::Shredder::ScripAction;
227     require RT::Shredder::ScripCondition;
228     require RT::Shredder::Template;
229     require RT::Shredder::ObjectCustomFieldValue;
230     require RT::Shredder::Ticket;
231     require RT::Shredder::Transaction;
232     require RT::Shredder::User;
233 }
234
235 our @SUPPORTED_OBJECTS = qw(
236     ACE
237     Attachment
238     CachedGroupMember
239     CustomField
240     CustomFieldValue
241     GroupMember
242     Group
243     Link
244     Principal
245     Queue
246     Scrip
247     ScripAction
248     ScripCondition
249     Template
250     ObjectCustomFieldValue
251     Ticket
252     Transaction
253     User
254 );
255
256 =head3 GENERIC
257
258 =head4 Init
259
260     RT::Shredder::Init( %default_options );
261
262 C<RT::Shredder::Init()> should be called before creating an
263 RT::Shredder object.  It iniitalizes RT and loads the RT
264 configuration.
265
266 %default_options are passed to every C<<RT::Shredder->new>> call.
267
268 =cut
269
270 our %opt = ();
271
272 sub Init
273 {
274     %opt = @_;
275     RT::LoadConfig();
276     RT::Init();
277 }
278
279 =head4 new
280
281   my $shredder = RT::Shredder->new(%options);
282
283 Construct a new RT::Shredder object.
284
285 There currently are no %options.
286
287 =cut
288
289 sub new
290 {
291     my $proto = shift;
292     my $self = bless( {}, ref $proto || $proto );
293     $self->_Init( @_ );
294     return $self;
295 }
296
297 sub _Init
298 {
299     my $self = shift;
300     $self->{'opt'}          = { %opt, @_ };
301     $self->{'cache'}        = {};
302     $self->{'resolver'}     = {};
303     $self->{'dump_plugins'} = [];
304 }
305
306 =head4 CastObjectsToRecords( Objects => undef )
307
308 Cast objects to the C<RT::Record> objects or its ancesstors.
309 Objects can be passed as SCALAR (format C<< <class>-<id> >>),
310 ARRAY, C<RT::Record> ancesstors or C<RT::SearchBuilder> ancesstor.
311
312 Most methods that takes C<Objects> argument use this method to
313 cast argument value to list of records.
314
315 Returns an array of records.
316
317 For example:
318
319     my @objs = $shredder->CastObjectsToRecords(
320         Objects => [             # ARRAY reference
321             'RT::Attachment-10', # SCALAR or SCALAR reference
322             $tickets,            # RT::Tickets object (isa RT::SearchBuilder)
323             $user,               # RT::User object (isa RT::Record)
324         ],
325     );
326
327 =cut
328
329 sub CastObjectsToRecords
330 {
331     my $self = shift;
332     my %args = ( Objects => undef, @_ );
333
334     my @res;
335     my $targets = delete $args{'Objects'};
336     unless( $targets ) {
337         RT::Shredder::Exception->throw( "Undefined Objects argument" );
338     }
339
340     if( UNIVERSAL::isa( $targets, 'RT::SearchBuilder' ) ) {
341         #XXX: try to use ->_DoSearch + ->ItemsArrayRef in feature
342         #     like we do in Record with links, but change only when
343         #     more tests would be available
344         while( my $tmp = $targets->Next ) { push @res, $tmp };
345     } elsif ( UNIVERSAL::isa( $targets, 'RT::Record' ) ) {
346         push @res, $targets;
347     } elsif ( UNIVERSAL::isa( $targets, 'ARRAY' ) ) {
348         foreach( @$targets ) {
349             push @res, $self->CastObjectsToRecords( Objects => $_ );
350         }
351     } elsif ( UNIVERSAL::isa( $targets, 'SCALAR' ) || !ref $targets ) {
352         $targets = $$targets if ref $targets;
353         my ($class, $id) = split /-/, $targets;
354         RT::Shredder::Exception->throw( "Unsupported class $class" )
355               unless $class =~ /^\w+(::\w+)*$/;
356         $class = 'RT::'. $class unless $class =~ /^RTx?::/i;
357         eval "require $class";
358         die "Couldn't load '$class' module" if $@;
359         my $obj = $class->new( RT->SystemUser );
360         die "Couldn't construct new '$class' object" unless $obj;
361         $obj->Load( $id );
362         unless ( $obj->id ) {
363             $RT::Logger->error( "Couldn't load '$class' object with id '$id'" );
364             RT::Shredder::Exception::Info->throw( 'CouldntLoadObject' );
365         }
366         die "Loaded object has different id" unless( $id eq $obj->id );
367         push @res, $obj;
368     } else {
369         RT::Shredder::Exception->throw( "Unsupported type ". ref $targets );
370     }
371     return @res;
372 }
373
374 =head3 OBJECTS CACHE
375
376 =head4 PutObjects( Objects => undef )
377
378 Puts objects into cache.
379
380 Returns array of the cache entries.
381
382 See C<CastObjectsToRecords> method for supported types of the C<Objects>
383 argument.
384
385 =cut
386
387 sub PutObjects
388 {
389     my $self = shift;
390     my %args = ( Objects => undef, @_ );
391
392     my @res;
393     for( $self->CastObjectsToRecords( Objects => delete $args{'Objects'} ) ) {
394         push @res, $self->PutObject( %args, Object => $_ )
395     }
396
397     return @res;
398 }
399
400 =head4 PutObject( Object => undef )
401
402 Puts record object into cache and returns its cache entry.
403
404 B<NOTE> that this method support B<only C<RT::Record> object or its ancesstor
405 objects>, if you want put mutliple objects or objects represented by different
406 classes then use C<PutObjects> method instead.
407
408 =cut
409
410 sub PutObject
411 {
412     my $self = shift;
413     my %args = ( Object => undef, @_ );
414
415     my $obj = $args{'Object'};
416     unless( UNIVERSAL::isa( $obj, 'RT::Record' ) ) {
417         RT::Shredder::Exception->throw( "Unsupported type '". (ref $obj || $obj || '(undef)')."'" );
418     }
419
420     my $str = $obj->_AsString;
421     return ($self->{'cache'}->{ $str } ||= { State => ON_STACK, Object => $obj } );
422 }
423
424 =head4 GetObject, GetState, GetRecord( String => ''| Object => '' )
425
426 Returns record object from cache, cache entry state or cache entry accordingly.
427
428 All three methods takes C<String> (format C<< <class>-<id> >>) or C<Object> argument.
429 C<String> argument has more priority than C<Object> so if it's not empty then methods
430 leave C<Object> argument unchecked.
431
432 You can read about possible states and their meanings in L<RT::Shredder::Constants> docs.
433
434 =cut
435
436 sub _ParseRefStrArgs
437 {
438     my $self = shift;
439     my %args = (
440         String => '',
441         Object => undef,
442         @_
443     );
444     if( $args{'String'} && $args{'Object'} ) {
445         require Carp;
446         Carp::croak( "both String and Object args passed" );
447     }
448     return $args{'String'} if $args{'String'};
449     return $args{'Object'}->_AsString if UNIVERSAL::can($args{'Object'}, '_AsString' );
450     return '';
451 }
452
453 sub GetObject { return (shift)->GetRecord( @_ )->{'Object'} }
454 sub GetState { return (shift)->GetRecord( @_ )->{'State'} }
455 sub GetRecord
456 {
457     my $self = shift;
458     my $str = $self->_ParseRefStrArgs( @_ );
459     return $self->{'cache'}->{ $str };
460 }
461
462 =head3 Dependencies resolvers
463
464 =head4 PutResolver, GetResolvers and ApplyResolvers
465
466 TODO: These methods have no documentation.
467
468 =cut
469
470 sub PutResolver
471 {
472     my $self = shift;
473     my %args = (
474         BaseClass => '',
475         TargetClass => '',
476         Code => undef,
477         @_,
478     );
479     unless( UNIVERSAL::isa( $args{'Code'} => 'CODE' ) ) {
480         die "Resolver '$args{Code}' is not code reference";
481     }
482
483     my $resolvers = (
484         (
485             $self->{'resolver'}->{ $args{'BaseClass'} } ||= {}
486         )->{  $args{'TargetClass'} || '' } ||= []
487     );
488     unshift @$resolvers, $args{'Code'};
489     return;
490 }
491
492 sub GetResolvers
493 {
494     my $self = shift;
495     my %args = (
496         BaseClass => '',
497         TargetClass => '',
498         @_,
499     );
500
501     my @res;
502     if( $args{'TargetClass'} && exists $self->{'resolver'}->{ $args{'BaseClass'} }->{ $args{'TargetClass'} } ) {
503         push @res, @{ $self->{'resolver'}->{ $args{'BaseClass'} }->{ $args{'TargetClass'} || '' } };
504     }
505     if( exists $self->{'resolver'}->{ $args{'BaseClass'} }->{ '' } ) {
506         push @res, @{ $self->{'resolver'}->{ $args{'BaseClass'} }->{''} };
507     }
508
509     return @res;
510 }
511
512 sub ApplyResolvers
513 {
514     my $self = shift;
515     my %args = ( Dependency => undef, @_ );
516     my $dep = $args{'Dependency'};
517
518     my @resolvers = $self->GetResolvers(
519         BaseClass   => $dep->BaseClass,
520         TargetClass => $dep->TargetClass,
521     );
522
523     unless( @resolvers ) {
524         RT::Shredder::Exception::Info->throw(
525             tag   => 'NoResolver',
526             error => "Couldn't find resolver for dependency '". $dep->AsString ."'",
527         );
528     }
529     $_->(
530         Shredder     => $self,
531         BaseObject   => $dep->BaseObject,
532         TargetObject => $dep->TargetObject,
533     ) foreach @resolvers;
534
535     return;
536 }
537
538 sub WipeoutAll
539 {
540     my $self = $_[0];
541
542     foreach my $cache_val ( values %{ $self->{'cache'} } ) {
543         next if $cache_val->{'State'} & (WIPED | IN_WIPING);
544         $self->Wipeout( Object => $cache_val->{'Object'} );
545     }
546 }
547
548 sub Wipeout
549 {
550     my $self = shift;
551     my $mark;
552     eval {
553         die "Couldn't begin transaction" unless $RT::Handle->BeginTransaction;
554         $mark = $self->PushDumpMark or die "Couldn't get dump mark";
555         $self->_Wipeout( @_ );
556         $self->PopDumpMark( Mark => $mark );
557         die "Couldn't commit transaction" unless $RT::Handle->Commit;
558     };
559     if( $@ ) {
560         my $error = $@;
561         $RT::Handle->Rollback('force');
562         $self->RollbackDumpTo( Mark => $mark ) if $mark;
563         die $error if RT::Shredder::Exception::Info->caught;
564         die "Couldn't wipeout object: $error";
565     }
566 }
567
568 sub _Wipeout
569 {
570     my $self = shift;
571     my %args = ( CacheRecord => undef, Object => undef, @_ );
572
573     my $record = $args{'CacheRecord'};
574     $record = $self->PutObject( Object => $args{'Object'} ) unless $record;
575     return if $record->{'State'} & (WIPED | IN_WIPING);
576
577     $record->{'State'} |= IN_WIPING;
578     my $object = $record->{'Object'};
579
580     $self->DumpObject( Object => $object, State => 'before any action' );
581
582     unless( $object->BeforeWipeout ) {
583         RT::Shredder::Exception->throw( "BeforeWipeout check returned error" );
584     }
585
586     my $deps = $object->Dependencies( Shredder => $self );
587     $deps->List(
588         WithFlags => DEPENDS_ON | VARIABLE,
589         Callback  => sub { $self->ApplyResolvers( Dependency => $_[0] ) },
590     );
591     $self->DumpObject( Object => $object, State => 'after resolvers' );
592
593     $deps->List(
594         WithFlags    => DEPENDS_ON,
595         WithoutFlags => WIPE_AFTER | VARIABLE,
596         Callback     => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) },
597     );
598     $self->DumpObject( Object => $object, State => 'after wiping dependencies' );
599
600     $object->__Wipeout;
601     $record->{'State'} |= WIPED; delete $record->{'Object'};
602     $self->DumpObject( Object => $object, State => 'after wipeout' );
603
604     $deps->List(
605         WithFlags => DEPENDS_ON | WIPE_AFTER,
606         WithoutFlags => VARIABLE,
607         Callback => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) },
608     );
609     $self->DumpObject( Object => $object, State => 'after late dependencies' );
610
611     return;
612 }
613
614 sub ValidateRelations
615 {
616     my $self = shift;
617     my %args = ( @_ );
618
619     foreach my $record( values %{ $self->{'cache'} } ) {
620         next if( $record->{'State'} & VALID );
621         $record->{'Object'}->ValidateRelations( Shredder => $self );
622     }
623 }
624
625 =head3 Data storage and backups
626
627 =head4 GetFileName( FileName => '<ISO DATETIME>-XXXX.sql', FromStorage => 1 )
628
629 Takes desired C<FileName> and flag C<FromStorage> then translate file name to absolute
630 path by next rules:
631
632 * Default value of the C<FileName> option is C<< <ISO DATETIME>-XXXX.sql >>;
633
634 * 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;
635
636 * 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.
637
638 * if C<FromStorage> argument is true (default behaviour) then result path would always be relative to C<StoragePath>;
639
640 * if C<FromStorage> argument is false then result would be relative to the current dir unless it's already absolute path.
641
642 Returns an absolute path of the file.
643
644 Examples:
645     # file from storage with default name format
646     my $fname = $shredder->GetFileName;
647
648     # file from storage with custom name format
649     my $fname = $shredder->GetFileName( FileName => 'shredder-XXXX.backup' );
650
651     # file with path relative to the current dir
652     my $fname = $shredder->GetFileName(
653         FromStorage => 0,
654         FileName => 'backups/shredder.sql',
655     );
656
657     # file with absolute path
658     my $fname = $shredder->GetFileName(
659         FromStorage => 0,
660         FileName => '/var/backups/shredder-XXXX.sql'
661     );
662
663 =cut
664
665 sub GetFileName
666 {
667     my $self = shift;
668     my %args = ( FileName => '', FromStorage => 1, @_ );
669
670     # default value
671     my $file = $args{'FileName'} || '%t-XXXX.sql';
672     if( $file =~ /\%t/i ) {
673         require POSIX;
674         my $date_time = POSIX::strftime( "%Y%m%dT%H%M%S", gmtime );
675         $file =~ s/\%t/$date_time/gi;
676     }
677
678     # convert to absolute path
679     if( $args{'FromStorage'} ) {
680         $file = File::Spec->catfile( $self->StoragePath, $file );
681     } elsif( !File::Spec->file_name_is_absolute( $file ) ) {
682         $file = File::Spec->rel2abs( $file );
683     }
684
685     # check mask
686     if( $file =~ /XXXX[^\/\\]*$/ ) {
687         my( $tmp, $i ) = ( $file, 0 );
688         do {
689             $i++;
690             $tmp = $file;
691             $tmp =~ s/XXXX([^\/\\]*)$/sprintf("%04d", $i).$1/e;
692         } while( -e $tmp && $i < 9999 );
693         $file = $tmp;
694     }
695
696     if( -f $file ) {
697         unless( -w _ ) {
698             die "File '$file' exists, but is read-only";
699         }
700     } elsif( !-e _ ) {
701         unless( File::Spec->file_name_is_absolute( $file ) ) {
702             $file = File::Spec->rel2abs( $file );
703         }
704
705         # check base dir
706         my $dir = File::Spec->join( (File::Spec->splitpath( $file ))[0,1] );
707         unless( -e $dir && -d _) {
708             die "Base directory '$dir' for file '$file' doesn't exist";
709         }
710         unless( -w $dir ) {
711             die "Base directory '$dir' is not writable";
712         }
713     } else {
714         die "'$file' is not regular file";
715     }
716
717     return $file;
718 }
719
720 =head4 StoragePath
721
722 Returns an absolute path to the storage dir.  See
723 L</$ShredderStoragePath>.
724
725 See also description of the L</GetFileName> method.
726
727 =cut
728
729 sub StoragePath
730 {
731     return scalar( RT->Config->Get('ShredderStoragePath') )
732         || File::Spec->catdir( $RT::VarPath, qw(data RT-Shredder) );
733 }
734
735 my %active_dump_state = ();
736 sub AddDumpPlugin {
737     my $self = shift;
738     my %args = ( Object => undef, Name => 'SQLDump', Arguments => undef, @_ );
739
740     my $plugin = $args{'Object'};
741     unless ( $plugin ) {
742         require RT::Shredder::Plugin;
743         $plugin = RT::Shredder::Plugin->new;
744         my( $status, $msg ) = $plugin->LoadByName( $args{'Name'} );
745         die "Couldn't load dump plugin: $msg\n" unless $status;
746     }
747     die "Plugin is not of correct type" unless lc $plugin->Type eq 'dump';
748
749     if ( my $pargs = $args{'Arguments'} ) {
750         my ($status, $msg) = $plugin->TestArgs( %$pargs );
751         die "Couldn't set plugin args: $msg\n" unless $status;
752     }
753
754     my @applies_to = $plugin->AppliesToStates;
755     die "Plugin doesn't apply to any state" unless @applies_to;
756     $active_dump_state{ lc $_ } = 1 foreach @applies_to;
757
758     push @{ $self->{'dump_plugins'} }, $plugin;
759
760     return $plugin;
761 }
762
763 sub DumpObject {
764     my $self = shift;
765     my %args = (Object => undef, State => undef, @_);
766     die "No state passed" unless $args{'State'};
767     return unless $active_dump_state{ lc $args{'State'} };
768
769     foreach (@{ $self->{'dump_plugins'} }) {
770         next unless grep lc $args{'State'} eq lc $_, $_->AppliesToStates;
771         my ($state, $msg) = $_->Run( %args );
772         die "Couldn't run plugin: $msg" unless $state;
773     }
774 }
775
776 { my $mark = 1; # XXX: integer overflows?
777 sub PushDumpMark {
778     my $self = shift;
779     $mark++;
780     foreach (@{ $self->{'dump_plugins'} }) {
781         my ($state, $msg) = $_->PushMark( Mark => $mark );
782         die "Couldn't push mark: $msg" unless $state;
783     }
784     return $mark;
785 }
786 sub PopDumpMark {
787     my $self = shift;
788     foreach (@{ $self->{'dump_plugins'} }) {
789         my ($state, $msg) = $_->PushMark( @_ );
790         die "Couldn't pop mark: $msg" unless $state;
791     }
792 }
793 sub RollbackDumpTo {
794     my $self = shift;
795     foreach (@{ $self->{'dump_plugins'} }) {
796         my ($state, $msg) = $_->RollbackTo( @_ );
797         die "Couldn't rollback to mark: $msg" unless $state;
798     }
799 }
800 }
801
802 1;
803 __END__
804
805 =head1 NOTES
806
807 =head2 Database transactions support
808
809 Since 0.03_01 RT::Shredder uses database transactions and should be
810 much safer to run on production servers.
811
812 =head2 Foreign keys
813
814 Mainstream RT doesn't use FKs, but at least I posted DDL script that creates them
815 in mysql DB, note that if you use FKs then this two valid keys don't allow delete
816 Tickets because of bug in MySQL:
817
818   ALTER TABLE Tickets ADD FOREIGN KEY (EffectiveId) REFERENCES Tickets(id);
819   ALTER TABLE CachedGroupMembers ADD FOREIGN KEY (Via) REFERENCES CachedGroupMembers(id);
820
821 L<http://bugs.mysql.com/bug.php?id=4042>
822
823 =head1 BUGS AND HOW TO CONTRIBUTE
824
825 We need your feedback in all cases: if you use it or not,
826 is it works for you or not.
827
828 =head2 Testing
829
830 Don't skip C<make test> step while install and send me reports if it's fails.
831 Add your own tests, it's easy enough if you've writen at list one perl script
832 that works with RT. Read more about testing in F<t/utils.pl>.
833
834 =head2 Reporting
835
836 Send reports to L</AUTHOR> or to the RT mailing lists.
837
838 =head2 Documentation
839
840 Many bugs in the docs: insanity, spelling, gramar and so on.
841 Patches are wellcome.
842
843 =head2 Todo
844
845 Please, see Todo file, it has some technical notes
846 about what I plan to do, when I'll do it, also it
847 describes some problems code has.
848
849 =head2 Repository
850
851 Since RT-3.7 shredder is a part of the RT distribution.
852 Versions of the RTx::Shredder extension could
853 be downloaded from the CPAN. Those work with older
854 RT versions or you can find repository at
855 L<https://opensvn.csie.org/rtx_shredder>
856
857 =head1 AUTHOR
858
859     Ruslan U. Zakirov <Ruslan.Zakirov@gmail.com>
860
861 =head1 COPYRIGHT
862
863 This program is free software; you can redistribute
864 it and/or modify it under the same terms as Perl itself.
865
866 The full text of the license can be found in the
867 Perl distribution.
868
869 =head1 SEE ALSO
870
871 L<rt-shredder>, L<rt-validator>
872
873 =cut