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