rt/lib/RT/Shredder.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2012 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         $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         my $error = $@;
 559         $RT::Handle->Rollback('force');
 560         $self->RollbackDumpTo( Mark => $mark ) if $mark;
 561         die $error if RT::Shredder::Exception::Info->caught;
 562         die "Couldn't wipeout object: $error";
 563     }
 564 }
 565
 566 sub _Wipeout
 567 {
 568     my $self = shift;
 569     my %args = ( CacheRecord => undef, Object => undef, @_ );
 570
 571     my $record = $args{'CacheRecord'};
 572     $record = $self->PutObject( Object => $args{'Object'} ) unless $record;
 573     return if $record->{'State'} & (WIPED | IN_WIPING);
 574
 575     $record->{'State'} |= IN_WIPING;
 576     my $object = $record->{'Object'};
 577
 578     $self->DumpObject( Object => $object, State => 'before any action' );
 579
 580     unless( $object->BeforeWipeout ) {
 581         RT::Shredder::Exception->throw( "BeforeWipeout check returned error" );
 582     }
 583
 584     my $deps = $object->Dependencies( Shredder => $self );
 585     $deps->List(
 586         WithFlags => DEPENDS_ON | VARIABLE,
 587         Callback  => sub { $self->ApplyResolvers( Dependency => $_[0] ) },
 588     );
 589     $self->DumpObject( Object => $object, State => 'after resolvers' );
 590
 591     $deps->List(
 592         WithFlags    => DEPENDS_ON,
 593         WithoutFlags => WIPE_AFTER | VARIABLE,
 594         Callback     => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) },
 595     );
 596     $self->DumpObject( Object => $object, State => 'after wiping dependencies' );
 597
 598     $object->__Wipeout;
 599     $record->{'State'} |= WIPED; delete $record->{'Object'};
 600     $self->DumpObject( Object => $object, State => 'after wipeout' );
 601
 602     $deps->List(
 603         WithFlags => DEPENDS_ON | WIPE_AFTER,
 604         WithoutFlags => VARIABLE,
 605         Callback => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) },
 606     );
 607     $self->DumpObject( Object => $object, State => 'after late dependencies' );
 608
 609     return;
 610 }
 611
 612 sub ValidateRelations
 613 {
 614     my $self = shift;
 615     my %args = ( @_ );
 616
 617     foreach my $record( values %{ $self->{'cache'} } ) {
 618         next if( $record->{'State'} & VALID );
 619         $record->{'Object'}->ValidateRelations( Shredder => $self );
 620     }
 621 }
 622
 623 =head3 Data storage and backups
 624
 625 =head4 GetFileName( FileName => '<ISO DATETIME>-XXXX.sql', FromStorage => 1 )
 626
 627 Takes desired C<FileName> and flag C<FromStorage> then translate file name to absolute
 628 path by next rules:
 629
 630 * Default value of the C<FileName> option is C<< <ISO DATETIME>-XXXX.sql >>;
 631
 632 * 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;
 633
 634 * 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.
 635
 636 * if C<FromStorage> argument is true (default behaviour) then result path would always be relative to C<StoragePath>;
 637
 638 * if C<FromStorage> argument is false then result would be relative to the current dir unless it's already absolute path.
 639
 640 Returns an absolute path of the file.
 641
 642 Examples:
 643     # file from storage with default name format
 644     my $fname = $shredder->GetFileName;
 645
 646     # file from storage with custom name format
 647     my $fname = $shredder->GetFileName( FileName => 'shredder-XXXX.backup' );
 648
 649     # file with path relative to the current dir
 650     my $fname = $shredder->GetFileName(
 651         FromStorage => 0,
 652         FileName => 'backups/shredder.sql',
 653     );
 654
 655     # file with absolute path
 656     my $fname = $shredder->GetFileName(
 657         FromStorage => 0,
 658         FileName => '/var/backups/shredder-XXXX.sql'
 659     );
 660
 661 =cut
 662
 663 sub GetFileName
 664 {
 665     my $self = shift;
 666     my %args = ( FileName => '', FromStorage => 1, @_ );
 667
 668     # default value
 669     my $file = $args{'FileName'} || '%t-XXXX.sql';
 670     if( $file =~ /\%t/i ) {
 671         require POSIX;
 672         my $date_time = POSIX::strftime( "%Y%m%dT%H%M%S", gmtime );
 673         $file =~ s/\%t/$date_time/gi;
 674     }
 675
 676     # convert to absolute path
 677     if( $args{'FromStorage'} ) {
 678         $file = File::Spec->catfile( $self->StoragePath, $file );
 679     } elsif( !File::Spec->file_name_is_absolute( $file ) ) {
 680         $file = File::Spec->rel2abs( $file );
 681     }
 682
 683     # check mask
 684     if( $file =~ /XXXX[^\/\\]*$/ ) {
 685         my( $tmp, $i ) = ( $file, 0 );
 686         do {
 687             $i++;
 688             $tmp = $file;
 689             $tmp =~ s/XXXX([^\/\\]*)$/sprintf("%04d", $i).$1/e;
 690         } while( -e $tmp && $i < 9999 );
 691         $file = $tmp;
 692     }
 693
 694     if( -f $file ) {
 695         unless( -w _ ) {
 696             die "File '$file' exists, but is read-only";
 697         }
 698     } elsif( !-e _ ) {
 699         unless( File::Spec->file_name_is_absolute( $file ) ) {
 700             $file = File::Spec->rel2abs( $file );
 701         }
 702
 703         # check base dir
 704         my $dir = File::Spec->join( (File::Spec->splitpath( $file ))[0,1] );
 705         unless( -e $dir && -d _) {
 706             die "Base directory '$dir' for file '$file' doesn't exist";
 707         }
 708         unless( -w $dir ) {
 709             die "Base directory '$dir' is not writable";
 710         }
 711     } else {
 712         die "'$file' is not regular file";
 713     }
 714
 715     return $file;
 716 }
 717
 718 =head4 StoragePath
 719
 720 Returns an absolute path to the storage dir.  See
 721 L<CONFIGURATION/$ShredderStoragePath>.
 722
 723 See also description of the L</GetFileName> method.
 724
 725 =cut
 726
 727 sub StoragePath
 728 {
 729     return scalar( RT->Config->Get('ShredderStoragePath') )
 730         || File::Spec->catdir( $RT::VarPath, qw(data RT-Shredder) );
 731 }
 732
 733 my %active_dump_state = ();
 734 sub AddDumpPlugin {
 735     my $self = shift;
 736     my %args = ( Object => undef, Name => 'SQLDump', Arguments => undef, @_ );
 737
 738     my $plugin = $args{'Object'};
 739     unless ( $plugin ) {
 740         require RT::Shredder::Plugin;
 741         $plugin = RT::Shredder::Plugin->new;
 742         my( $status, $msg ) = $plugin->LoadByName( $args{'Name'} );
 743         die "Couldn't load dump plugin: $msg\n" unless $status;
 744     }
 745     die "Plugin is not of correct type" unless lc $plugin->Type eq 'dump';
 746
 747     if ( my $pargs = $args{'Arguments'} ) {
 748         my ($status, $msg) = $plugin->TestArgs( %$pargs );
 749         die "Couldn't set plugin args: $msg\n" unless $status;
 750     }
 751
 752     my @applies_to = $plugin->AppliesToStates;
 753     die "Plugin doesn't apply to any state" unless @applies_to;
 754     $active_dump_state{ lc $_ } = 1 foreach @applies_to;
 755
 756     push @{ $self->{'dump_plugins'} }, $plugin;
 757
 758     return $plugin;
 759 }
 760
 761 sub DumpObject {
 762     my $self = shift;
 763     my %args = (Object => undef, State => undef, @_);
 764     die "No state passed" unless $args{'State'};
 765     return unless $active_dump_state{ lc $args{'State'} };
 766
 767     foreach (@{ $self->{'dump_plugins'} }) {
 768         next unless grep lc $args{'State'} eq lc $_, $_->AppliesToStates;
 769         my ($state, $msg) = $_->Run( %args );
 770         die "Couldn't run plugin: $msg" unless $state;
 771     }
 772 }
 773
 774 { my $mark = 1; # XXX: integer overflows?
 775 sub PushDumpMark {
 776     my $self = shift;
 777     $mark++;
 778     foreach (@{ $self->{'dump_plugins'} }) {
 779         my ($state, $msg) = $_->PushMark( Mark => $mark );
 780         die "Couldn't push mark: $msg" unless $state;
 781     }
 782     return $mark;
 783 }
 784 sub PopDumpMark {
 785     my $self = shift;
 786     foreach (@{ $self->{'dump_plugins'} }) {
 787         my ($state, $msg) = $_->PushMark( @_ );
 788         die "Couldn't pop mark: $msg" unless $state;
 789     }
 790 }
 791 sub RollbackDumpTo {
 792     my $self = shift;
 793     foreach (@{ $self->{'dump_plugins'} }) {
 794         my ($state, $msg) = $_->RollbackTo( @_ );
 795         die "Couldn't rollback to mark: $msg" unless $state;
 796     }
 797 }
 798 }
 799
 800 1;
 801 __END__
 802
 803 =head1 NOTES
 804
 805 =head2 Database transactions support
 806
 807 Since 0.03_01 RT::Shredder uses database transactions and should be
 808 much safer to run on production servers.
 809
 810 =head2 Foreign keys
 811
 812 Mainstream RT doesn't use FKs, but at least I posted DDL script that creates them
 813 in mysql DB, note that if you use FKs then this two valid keys don't allow delete
 814 Tickets because of bug in MySQL:
 815
 816   ALTER TABLE Tickets ADD FOREIGN KEY (EffectiveId) REFERENCES Tickets(id);
 817   ALTER TABLE CachedGroupMembers ADD FOREIGN KEY (Via) REFERENCES CachedGroupMembers(id);
 818
 819 L<http://bugs.mysql.com/bug.php?id=4042>
 820
 821 =head1 BUGS AND HOW TO CONTRIBUTE
 822
 823 We need your feedback in all cases: if you use it or not,
 824 is it works for you or not.
 825
 826 =head2 Testing
 827
 828 Don't skip C<make test> step while install and send me reports if it's fails.
 829 Add your own tests, it's easy enough if you've writen at list one perl script
 830 that works with RT. Read more about testing in F<t/utils.pl>.
 831
 832 =head2 Reporting
 833
 834 Send reports to L</AUTHOR> or to the RT mailing lists.
 835
 836 =head2 Documentation
 837
 838 Many bugs in the docs: insanity, spelling, gramar and so on.
 839 Patches are wellcome.
 840
 841 =head2 Todo
 842
 843 Please, see Todo file, it has some technical notes
 844 about what I plan to do, when I'll do it, also it
 845 describes some problems code has.
 846
 847 =head2 Repository
 848
 849 Since RT-3.7 shredder is a part of the RT distribution.
 850 Versions of the RTx::Shredder extension could
 851 be downloaded from the CPAN. Those work with older
 852 RT versions or you can find repository at
 853 L<https://opensvn.csie.org/rtx_shredder>
 854
 855 =head1 AUTHOR
 856
 857     Ruslan U. Zakirov <Ruslan.Zakirov@gmail.com>
 858
 859 =head1 COPYRIGHT
 860
 861 This program is free software; you can redistribute
 862 it and/or modify it under the same terms as Perl itself.
 863
 864 The full text of the license can be found in the
 865 Perl distribution.
 866
 867 =head1 SEE ALSO
 868
 869 L<rt-shredder>, L<rt-validator>
 870
 871 =cut