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