lib/RT/Shredder.pm

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