rt/lib/RT/Shredder.pm

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