rt/lib/RT/Shredder.pm

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