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