1# BEGIN BPS TAGGED BLOCK {{{ 2# 3# COPYRIGHT: 4# 5# This software is Copyright (c) 1996-2021 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 49package RT::Shredder; 50 51use strict; 52use warnings; 53 54 55 56=head1 NAME 57 58RT::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 69RT::Shredder is extension to RT which allows you to permanently wipeout 70data from the RT database. Shredder supports the wiping of almost 71all RT objects (Tickets, Transactions, Attachments, Users...). 72 73 74=head2 "Delete" vs "Wipeout" 75 76RT uses the term "delete" to mean "deactivate". To avoid confusion, 77RT::Shredder uses the term "Wipeout" to mean "permanently erase" (or 78what most people would think of as "delete"). 79 80 81=head2 Why do you want this? 82 83Normally in RT, "deleting" an item simply deactivates it and makes it 84invisible from view. This is done to retain full history and 85auditability of your tickets. For most RT users this is fine and they 86have no need of RT::Shredder. 87 88But in some large and heavily used RT instances the database can get 89clogged up with junk, particularly spam. This can slow down searches 90and bloat the size of the database. For these users, RT::Shredder 91allows them to completely clear the database of this unwanted junk. 92 93An additional use of Shredder is to obliterate sensitive information 94(passwords, credit card numbers, ...) which might have made their way 95into RT. 96 97 98=head2 Command line tools (CLI) 99 100L<rt-shredder> is a program which allows you to wipe objects from 101command line or with system tasks scheduler (cron, for example). 102See also 'rt-shredder --help'. 103 104 105=head2 Web based interface (WebUI) 106 107Shredder's WebUI integrates into RT's WebUI. You can find it in the 108Admin->Tools->Shredder tab. The interface is similar to the 109CLI and gives you the same functionality. You can find 'Shredder' link 110at the bottom of tickets search results, so you could wipeout tickets 111in the way similar to the bulk update. 112 113 114=head1 DATA STORAGE AND BACKUPS 115 116Shredder allows you to store data you wiped in files as scripts with SQL 117commands. 118 119=head3 Restoring from backup 120 121Should you wipeout something you did not intend to the objects can be 122restored by using the storage files. These files are a simple set of 123SQL commands to re-insert your objects into the RT database. 124 1251) 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 1302) 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 136That's it.i This will restore everything you'd deleted during a 137shredding session when the file had been created. 138 139=head1 CONFIGURATION 140 141=head2 $DependenciesLimit 142 143Shredder stops with an error if the object has more than 144C<$DependenciesLimit> dependencies. For example: a ticket has 1000 145transactions or a transaction has 1000 attachments. This is protection 146from bugs in shredder from wiping out your whole database, but 147sometimes when you have big mail loops you may hit it. 148 149Defaults to 1000. To change this (for example, to 10000) add the 150following to your F<RT_SiteConfig.pm>: 151 152 Set( $DependenciesLimit, 10_000 );> 153 154 155=head2 $ShredderStoragePath 156 157Directory containing Shredder backup dumps; defaults to 158F</opt/rt5/var/data/RT-Shredder> (assuming an /opt/rt5 installation). 159 160To change this (for example, to /some/backup/path) add the following to 161your F<RT_SiteConfig.pm>: 162 163 Set( $ShredderStoragePath, "/some/backup/path" );> 164 165Be sure to specify an absolute path. 166 167=head1 Database Indexes 168 169We have found that the following indexes significantly speed up 170shredding on most databases. However they are intended to be deployed 171only for the duration of your shredding, as they may have an adverse 172effect on the performance of ordinary RT operations. 173 174 CREATE INDEX SHREDDER_CGM1 ON CachedGroupMembers(MemberId, GroupId, Disabled); 175 CREATE INDEX SHREDDER_CGM2 ON CachedGroupMembers(ImmediateParentId,MemberId); 176 CREATE INDEX SHREDDER_CGM3 on CachedGroupMembers (Via, Id); 177 178 CREATE UNIQUE INDEX SHREDDER_GM1 ON GroupMembers(MemberId, GroupId); 179 180 CREATE INDEX SHREDDER_TXN1 ON Transactions(ReferenceType, OldReference); 181 CREATE INDEX SHREDDER_TXN2 ON Transactions(ReferenceType, NewReference); 182 CREATE INDEX SHREDDER_TXN3 ON Transactions(Type, OldValue); 183 CREATE INDEX SHREDDER_TXN4 ON Transactions(Type, NewValue); 184 185 CREATE INDEX SHREDDER_ATTACHMENTS1 ON Attachments(Creator); 186 187 CREATE INDEX SHREDDER_LINKS1 ON Links(Target); 188 189 CREATE INDEX SHREDDER_ACL1 ON ACL(ObjectType, ObjectId); 190 191 CREATE INDEX SHREDDER_OCFV1 ON ObjectCustomFieldValues(ObjectType, ObjectId); 192 193=head1 INFORMATION FOR DEVELOPERS 194 195=head2 General API 196 197L<RT::Shredder> is an extension to RT which adds shredder methods to 198RT objects and classes. The API is not well documented yet, but you 199can find usage examples in L<rt-shredder> and the 200F<lib/t/regression/shredder/*.t> test files. 201 202However, here is a small example that do the same action as in CLI 203example from L</SYNOPSIS>: 204 205 use RT::Shredder; 206 RT::Shredder::Init( force => 1 ); 207 my $deleted = RT::Tickets->new( RT->SystemUser ); 208 $deleted->{'allow_deleted_search'} = 1; 209 $deleted->LimitQueue( VALUE => 'general' ); 210 $deleted->LimitStatus( VALUE => 'deleted' ); 211 while( my $t = $deleted->Next ) { 212 $t->Wipeout; 213 } 214 215 216=head2 RT::Shredder class' API 217 218L<RT::Shredder> implements interfaces to objects cache, actions on the 219objects in the cache and backups storage. 220 221=cut 222 223use File::Spec (); 224 225 226BEGIN { 227# I can't use 'use lib' here since it breakes tests 228# because test suite uses old RT::Shredder setup from 229# RT lib path 230 231### after: push @INC, qw(@RT_LIB_PATH@); 232 use RT::Shredder::Constants; 233 use RT::Shredder::Exceptions; 234} 235 236our @SUPPORTED_OBJECTS = qw( 237 ACE 238 Attachment 239 CachedGroupMember 240 CustomField 241 CustomFieldValue 242 GroupMember 243 Group 244 Link 245 Principal 246 Queue 247 Scrip 248 ScripAction 249 ScripCondition 250 Template 251 ObjectCustomFieldValue 252 Ticket 253 Transaction 254 User 255); 256 257=head3 GENERIC 258 259=head4 Init 260 261 RT::Shredder::Init( %default_options ); 262 263C<RT::Shredder::Init()> should be called before creating an 264RT::Shredder object. It iniitalizes RT and loads the RT 265configuration. 266 267%default_options are passed to every C<<RT::Shredder->new>> call. 268 269=cut 270 271our %opt = (); 272 273sub Init 274{ 275 %opt = @_; 276 RT::LoadConfig(); 277 RT::Init(); 278 return; 279} 280 281=head4 new 282 283 my $shredder = RT::Shredder->new(%options); 284 285Construct a new RT::Shredder object. 286 287There currently are no %options. 288 289=cut 290 291sub new 292{ 293 my $proto = shift; 294 my $self = bless( {}, ref $proto || $proto ); 295 return $self->_Init( @_ ); 296} 297 298sub _Init 299{ 300 my $self = shift; 301 $self->{'opt'} = { %opt, @_ }; 302 $self->{'cache'} = {}; 303 $self->{'resolver'} = {}; 304 $self->{'dump_plugins'} = []; 305 return $self; 306} 307 308=head4 CastObjectsToRecords( Objects => undef ) 309 310Cast objects to the C<RT::Record> objects or its ancesstors. 311Objects can be passed as SCALAR (format C<< <class>-<id> >>), 312ARRAY, C<RT::Record> ancesstors or C<RT::SearchBuilder> ancesstor. 313 314Most methods that takes C<Objects> argument use this method to 315cast argument value to list of records. 316 317Returns an array of records. 318 319For example: 320 321 my @objs = $shredder->CastObjectsToRecords( 322 Objects => [ # ARRAY reference 323 'RT::Attachment-10', # SCALAR or SCALAR reference 324 $tickets, # RT::Tickets object (isa RT::SearchBuilder) 325 $user, # RT::User object (isa RT::Record) 326 ], 327 ); 328 329=cut 330 331sub CastObjectsToRecords 332{ 333 my $self = shift; 334 my %args = ( Objects => undef, @_ ); 335 336 my @res; 337 my $targets = delete $args{'Objects'}; 338 unless( $targets ) { 339 RT::Shredder::Exception->throw( "Undefined Objects argument" ); 340 } 341 342 if( UNIVERSAL::isa( $targets, 'RT::SearchBuilder' ) ) { 343 #XXX: try to use ->_DoSearch + ->ItemsArrayRef in feature 344 # like we do in Record with links, but change only when 345 # more tests would be available 346 while( my $tmp = $targets->Next ) { push @res, $tmp }; 347 } elsif ( UNIVERSAL::isa( $targets, 'RT::Record' ) ) { 348 push @res, $targets; 349 } elsif ( UNIVERSAL::isa( $targets, 'ARRAY' ) ) { 350 foreach( @$targets ) { 351 push @res, $self->CastObjectsToRecords( Objects => $_ ); 352 } 353 } elsif ( UNIVERSAL::isa( $targets, 'SCALAR' ) || !ref $targets ) { 354 $targets = $$targets if ref $targets; 355 my $Organization = RT->Config->Get('Organization'); 356 my ($class, $id); 357 if ($targets =~ /^([\w:]+)-\Q$Organization\E-(.+)$/) { 358 ($class, $id) = ($1, $2); 359 } elsif ($targets =~ /^(RT::User)-(.*)$/) { 360 ($class, $id) = ($1, $2); 361 } elsif ($targets =~ /-.*-/) { 362 RT::Shredder::Exception->throw( "Can't wipeout remote object $targets" ); 363 } else { 364 ($class, $id) = split /-/, $targets; 365 } 366 RT::Shredder::Exception->throw( "Unsupported class $class" ) 367 unless $class =~ /^\w+(::\w+)*$/; 368 $class = 'RT::'. $class unless $class =~ /^RTx?::/i; 369 $class->require or die "Failed to load $class: $@"; 370 my $obj = $class->new( RT->SystemUser ); 371 die "Couldn't construct new '$class' object" unless $obj; 372 $obj->Load( $id ); 373 unless ( $obj->id ) { 374 $RT::Logger->error( "Couldn't load '$class' object with id '$id'" ); 375 RT::Shredder::Exception::Info->throw( 'CouldntLoadObject' ); 376 } 377 378 if ( $id =~ /^\d+$/ ) { 379 if ( $id ne $obj->Id ) { 380 die 'Loaded object id ' . $obj->Id . " is different from passed id $id"; 381 } 382 } 383 else { 384 if ( $obj->_Accessible( 'Name', 'read' ) && $id ne $obj->Name ) { 385 die 'Loaded object name ' . $obj->Name . " is different from passed name $id"; 386 } 387 } 388 push @res, $obj; 389 } else { 390 RT::Shredder::Exception->throw( "Unsupported type ". ref $targets ); 391 } 392 return @res; 393} 394 395=head3 OBJECTS CACHE 396 397=head4 PutObjects( Objects => undef ) 398 399Puts objects into cache. 400 401Returns array of the cache entries. 402 403See C<CastObjectsToRecords> method for supported types of the C<Objects> 404argument. 405 406=cut 407 408sub PutObjects 409{ 410 my $self = shift; 411 my %args = ( Objects => undef, @_ ); 412 413 my @res; 414 for( $self->CastObjectsToRecords( Objects => delete $args{'Objects'} ) ) { 415 push @res, $self->PutObject( %args, Object => $_ ) 416 } 417 418 return @res; 419} 420 421=head4 PutObject( Object => undef ) 422 423Puts record object into cache and returns its cache entry. 424 425B<NOTE> that this method support B<only C<RT::Record> object or its ancesstor 426objects>, if you want put mutliple objects or objects represented by different 427classes then use C<PutObjects> method instead. 428 429=cut 430 431sub PutObject 432{ 433 my $self = shift; 434 my %args = ( Object => undef, @_ ); 435 436 my $obj = $args{'Object'}; 437 unless( UNIVERSAL::isa( $obj, 'RT::Record' ) ) { 438 RT::Shredder::Exception->throw( "Unsupported type '". (ref $obj || $obj || '(undef)')."'" ); 439 } 440 441 my $str = $obj->UID; 442 return ($self->{'cache'}->{ $str } ||= { 443 State => RT::Shredder::Constants::ON_STACK, 444 Object => $obj 445 } ); 446} 447 448=head4 GetObject, GetState, GetRecord( String => ''| Object => '' ) 449 450Returns record object from cache, cache entry state or cache entry accordingly. 451 452All three methods takes C<String> (format C<< <class>-<id> >>) or C<Object> argument. 453C<String> argument has more priority than C<Object> so if it's not empty then methods 454leave C<Object> argument unchecked. 455 456You can read about possible states and their meanings in L<RT::Shredder::Constants> docs. 457 458=cut 459 460sub _ParseRefStrArgs 461{ 462 my $self = shift; 463 my %args = ( 464 String => '', 465 Object => undef, 466 @_ 467 ); 468 if( $args{'String'} && $args{'Object'} ) { 469 require Carp; 470 Carp::croak( "both String and Object args passed" ); 471 } 472 return $args{'String'} if $args{'String'}; 473 return $args{'Object'}->UID if UNIVERSAL::can($args{'Object'}, 'UID' ); 474 return ''; 475} 476 477sub GetObject { return (shift)->GetRecord( @_ )->{'Object'} } 478sub GetState { return (shift)->GetRecord( @_ )->{'State'} } 479sub GetRecord 480{ 481 my $self = shift; 482 my $str = $self->_ParseRefStrArgs( @_ ); 483 return $self->{'cache'}->{ $str }; 484} 485 486=head3 Dependencies resolvers 487 488=head4 PutResolver, GetResolvers and ApplyResolvers 489 490TODO: These methods have no documentation. 491 492=cut 493 494sub PutResolver 495{ 496 my $self = shift; 497 my %args = ( 498 BaseClass => '', 499 TargetClass => '', 500 Code => undef, 501 @_, 502 ); 503 unless( UNIVERSAL::isa( $args{'Code'} => 'CODE' ) ) { 504 die "Resolver '$args{Code}' is not code reference"; 505 } 506 507 my $resolvers = ( 508 ( 509 $self->{'resolver'}->{ $args{'BaseClass'} } ||= {} 510 )->{ $args{'TargetClass'} || '' } ||= [] 511 ); 512 unshift @$resolvers, $args{'Code'}; 513 return; 514} 515 516sub GetResolvers 517{ 518 my $self = shift; 519 my %args = ( 520 BaseClass => '', 521 TargetClass => '', 522 @_, 523 ); 524 525 my @res; 526 if( $args{'TargetClass'} && exists $self->{'resolver'}->{ $args{'BaseClass'} }->{ $args{'TargetClass'} } ) { 527 push @res, @{ $self->{'resolver'}->{ $args{'BaseClass'} }->{ $args{'TargetClass'} || '' } }; 528 } 529 if( exists $self->{'resolver'}->{ $args{'BaseClass'} }->{ '' } ) { 530 push @res, @{ $self->{'resolver'}->{ $args{'BaseClass'} }->{''} }; 531 } 532 533 return @res; 534} 535 536sub ApplyResolvers 537{ 538 my $self = shift; 539 my %args = ( Dependency => undef, @_ ); 540 my $dep = $args{'Dependency'}; 541 542 my @resolvers = $self->GetResolvers( 543 BaseClass => $dep->BaseClass, 544 TargetClass => $dep->TargetClass, 545 ); 546 547 unless( @resolvers ) { 548 RT::Shredder::Exception::Info->throw( 549 tag => 'NoResolver', 550 error => "Couldn't find resolver for dependency '". $dep->AsString ."'", 551 ); 552 } 553 $_->( 554 Shredder => $self, 555 BaseObject => $dep->BaseObject, 556 TargetObject => $dep->TargetObject, 557 ) foreach @resolvers; 558 559 return; 560} 561 562sub WipeoutAll 563{ 564 my $self = $_[0]; 565 566 foreach my $cache_val ( values %{ $self->{'cache'} } ) { 567 next if $cache_val->{'State'} & (RT::Shredder::Constants::WIPED | RT::Shredder::Constants::IN_WIPING); 568 $self->Wipeout( Object => $cache_val->{'Object'} ); 569 } 570 return; 571} 572 573sub Wipeout 574{ 575 my $self = shift; 576 my $mark; 577 eval { 578 die "Couldn't begin transaction" unless $RT::Handle->BeginTransaction; 579 $mark = $self->PushDumpMark or die "Couldn't get dump mark"; 580 $self->_Wipeout( @_ ); 581 $self->PopDumpMark( Mark => $mark ); 582 die "Couldn't commit transaction" unless $RT::Handle->Commit; 583 }; 584 if( $@ ) { 585 my $error = $@; 586 $RT::Handle->Rollback('force'); 587 $self->RollbackDumpTo( Mark => $mark ) if $mark; 588 die $error if RT::Shredder::Exception::Info->caught; 589 die "Couldn't wipeout object: $error"; 590 } 591 return; 592} 593 594sub _Wipeout 595{ 596 my $self = shift; 597 my %args = ( CacheRecord => undef, Object => undef, @_ ); 598 599 my $record = $args{'CacheRecord'}; 600 $record = $self->PutObject( Object => $args{'Object'} ) unless $record; 601 return if $record->{'State'} & (RT::Shredder::Constants::WIPED | RT::Shredder::Constants::IN_WIPING); 602 603 $record->{'State'} |= RT::Shredder::Constants::IN_WIPING; 604 my $object = $record->{'Object'}; 605 606 $self->DumpObject( Object => $object, State => 'before any action' ); 607 608 unless( $object->BeforeWipeout ) { 609 RT::Shredder::Exception->throw( "BeforeWipeout check returned error" ); 610 } 611 612 my $deps = $object->Dependencies( Shredder => $self ); 613 $deps->List( 614 WithFlags => RT::Shredder::Constants::DEPENDS_ON | RT::Shredder::Constants::VARIABLE, 615 Callback => sub { $self->ApplyResolvers( Dependency => $_[0] ) }, 616 ); 617 $self->DumpObject( Object => $object, State => 'after resolvers' ); 618 619 $deps->List( 620 WithFlags => RT::Shredder::Constants::DEPENDS_ON, 621 WithoutFlags => RT::Shredder::Constants::WIPE_AFTER | RT::Shredder::Constants::VARIABLE, 622 Callback => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) }, 623 ); 624 $self->DumpObject( Object => $object, State => 'after wiping dependencies' ); 625 626 $object->__Wipeout; 627 $record->{'State'} |= RT::Shredder::Constants::WIPED; delete $record->{'Object'}; 628 $self->DumpObject( Object => $object, State => 'after wipeout' ); 629 630 $deps->List( 631 WithFlags => RT::Shredder::Constants::DEPENDS_ON | RT::Shredder::Constants::WIPE_AFTER, 632 WithoutFlags => RT::Shredder::Constants::VARIABLE, 633 Callback => sub { $self->_Wipeout( Object => $_[0]->TargetObject ) }, 634 ); 635 $self->DumpObject( Object => $object, State => 'after late dependencies' ); 636 637 return; 638} 639 640=head3 Data storage and backups 641 642=head4 GetFileName( FileName => '<ISO DATETIME>-XXXX.sql', FromStorage => 1 ) 643 644Takes desired C<FileName> and flag C<FromStorage> then translate file name to absolute 645path 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 657Returns an absolute path of the file. 658 659Examples: 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 680sub 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 737Returns an absolute path to the storage dir. See 738L</$ShredderStoragePath>. 739 740See also description of the L</GetFileName> method. 741 742=cut 743 744sub StoragePath 745{ 746 return scalar( RT->Config->Get('ShredderStoragePath') ) 747 || File::Spec->catdir( $RT::VarPath, qw(data RT-Shredder) ); 748} 749 750my %active_dump_state = (); 751sub 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 778sub 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 return; 790} 791 792{ my $mark = 1; # XXX: integer overflows? 793sub PushDumpMark { 794 my $self = shift; 795 $mark++; 796 foreach (@{ $self->{'dump_plugins'} }) { 797 my ($state, $msg) = $_->PushMark( Mark => $mark ); 798 die "Couldn't push mark: $msg" unless $state; 799 } 800 return $mark; 801} 802sub PopDumpMark { 803 my $self = shift; 804 foreach (@{ $self->{'dump_plugins'} }) { 805 my ($state, $msg) = $_->PopMark( @_ ); 806 die "Couldn't pop mark: $msg" unless $state; 807 } 808 return; 809} 810sub RollbackDumpTo { 811 my $self = shift; 812 foreach (@{ $self->{'dump_plugins'} }) { 813 my ($state, $msg) = $_->RollbackTo( @_ ); 814 die "Couldn't rollback to mark: $msg" unless $state; 815 } 816 return; 817} 818} 819 8201; 821__END__ 822 823=head1 SEE ALSO 824 825L<rt-shredder>, L<rt-validator> 826 827=cut 828