rt/lib/RT/Record.pm

   1 # {{{ BEGIN BPS TAGGED BLOCK
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2004 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  26 #
  27 #
  28 # CONTRIBUTION SUBMISSION POLICY:
  29 #
  30 # (The following paragraph is not intended to limit the rights granted
  31 # to you to modify and distribute this software under the terms of
  32 # the GNU General Public License and is only of importance to you if
  33 # you choose to contribute your changes and enhancements to the
  34 # community by submitting them to Best Practical Solutions, LLC.)
  35 #
  36 # By intentionally submitting any modifications, corrections or
  37 # derivatives to this work, or any other work intended for use with
  38 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  39 # you are the copyright holder for those contributions and you grant
  40 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  41 # royalty-free, perpetual, license to use, copy, create derivative
  42 # works based on those contributions, and sublicense and distribute
  43 # those contributions and any derivatives thereof.
  44 #
  45 # }}} END BPS TAGGED BLOCK
  46 =head1 NAME
  47
  48   RT::Record - Base class for RT record objects
  49
  50 =head1 SYNOPSIS
  51
  52
  53 =head1 DESCRIPTION
  54
  55
  56 =begin testing
  57
  58 ok (require RT::Record);
  59
  60 =end testing
  61
  62 =head1 METHODS
  63
  64 =cut
  65
  66 package RT::Record;
  67 use RT::Date;
  68 use RT::User;
  69 use RT::Attributes;
  70 use RT::Base;
  71 use DBIx::SearchBuilder::Record::Cachable;
  72
  73 use strict;
  74 use vars qw/@ISA $_TABLE_ATTR/;
  75
  76 @ISA = qw(RT::Base);
  77
  78 if ($RT::DontCacheSearchBuilderRecords ) {
  79     push (@ISA, 'DBIx::SearchBuilder::Record');
  80 } else {
  81     push (@ISA, 'DBIx::SearchBuilder::Record::Cachable');
  82
  83 }
  84
  85 # {{{ sub _Init
  86
  87 sub _Init {
  88     my $self = shift;
  89     $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
  90     $self->CurrentUser(@_);
  91 }
  92
  93 # }}}
  94
  95 # {{{ _PrimaryKeys
  96
  97 =head2 _PrimaryKeys
  98
  99 The primary keys for RT classes is 'id'
 100
 101 =cut
 102
 103 sub _PrimaryKeys {
 104     my $self = shift;
 105     return ( ['id'] );
 106 }
 107
 108 # }}}
 109
 110 =head2 Attributes
 111
 112 Return this object's attributes as an RT::Attributes object
 113
 114 =cut
 115
 116 sub Attributes {
 117     my $self = shift;
 118
 119     unless ($self->{'attributes'}) {
 120         $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
 121        $self->{'attributes'}->LimitToObject($self);
 122     }
 123     return ($self->{'attributes'});
 124
 125 }
 126
 127
 128 =head2 AddAttribute { Name, Description, Content }
 129
 130 Adds a new attribute for this object.
 131
 132 =cut
 133
 134 sub AddAttribute {
 135     my $self = shift;
 136     my %args = ( Name        => undef,
 137                  Description => undef,
 138                  Content     => undef,
 139                  @_ );
 140
 141     my $attr = RT::Attribute->new( $self->CurrentUser );
 142     my ( $id, $msg ) = $attr->Create(
 143                                       Object    => $self,
 144                                       Name        => $args{'Name'},
 145                                       Description => $args{'Description'},
 146                                       Content     => $args{'Content'} );
 147
 148     $self->Attributes->RedoSearch;
 149
 150     return ($id, $msg);
 151 }
 152
 153
 154 =head2 SetAttribute { Name, Description, Content }
 155
 156 Like AddAttribute, but replaces all existing attributes with the same Name.
 157
 158 =cut
 159
 160 sub SetAttribute {
 161     my $self = shift;
 162     my %args = ( Name        => undef,
 163                  Description => undef,
 164                  Content     => undef,
 165                  @_ );
 166
 167     my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
 168         or return $self->AddAttribute( %args );
 169
 170     my $AttributeObj = pop( @AttributeObjs );
 171     $_->Delete foreach @AttributeObjs;
 172
 173     $AttributeObj->SetDescription( $args{'Description'} );
 174     $AttributeObj->SetContent( $args{'Content'} );
 175
 176     $self->Attributes->RedoSearch;
 177     return 1;
 178 }
 179
 180 =head2 DeleteAttribute NAME
 181
 182 Deletes all attributes with the matching name for this object.
 183
 184 =cut
 185
 186 sub DeleteAttribute {
 187     my $self = shift;
 188     my $name = shift;
 189     return $self->Attributes->DeleteEntry( Name => $name );
 190 }
 191
 192 =head2 FirstAttribute NAME
 193
 194 Returns the value of the first attribute with the matching name
 195 for this object, or C<undef> if no such attributes exist.
 196
 197 =cut
 198
 199 sub FirstAttribute {
 200     my $self = shift;
 201     my $name = shift;
 202     return ($self->Attributes->Named( $name ))[0];
 203 }
 204
 205
 206 # {{{ sub _Handle
 207 sub _Handle {
 208     my $self = shift;
 209     return ($RT::Handle);
 210 }
 211
 212 # }}}
 213
 214 # {{{ sub Create
 215
 216 =item  Create PARAMHASH
 217
 218 Takes a PARAMHASH of Column -> Value pairs.
 219 If any Column has a Validate$PARAMNAME subroutine defined and the
 220 value provided doesn't pass validation, this routine returns
 221 an error.
 222
 223 If this object's table has any of the following atetributes defined as
 224 'Auto', this routine will automatically fill in their values.
 225
 226 =cut
 227
 228 sub Create {
 229     my $self    = shift;
 230     my %attribs = (@_);
 231     foreach my $key ( keys %attribs ) {
 232         my $method = "Validate$key";
 233         unless ( $self->$method( $attribs{$key} ) ) {
 234             if (wantarray) {
 235                 return ( 0, $self->loc('Invalid value for [_1]', $key) );
 236             }
 237             else {
 238                 return (0);
 239             }
 240         }
 241     }
 242     my $now = RT::Date->new( $self->CurrentUser );
 243     $now->Set( Format => 'unix', Value => time );
 244     $attribs{'Created'} = $now->ISO() if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
 245
 246     if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
 247          $attribs{'Creator'} = $self->CurrentUser->id || '0';
 248     }
 249     $attribs{'LastUpdated'} = $now->ISO()
 250       if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
 251
 252     $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
 253       if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
 254
 255     my $id = $self->SUPER::Create(%attribs);
 256     if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
 257         if ( $id->errno ) {
 258             if (wantarray) {
 259                 return ( 0,
 260                     $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
 261             }
 262             else {
 263                 return (0);
 264             }
 265         }
 266     }
 267     # If the object was created in the database,
 268     # load it up now, so we're sure we get what the database
 269     # has.  Arguably, this should not be necessary, but there
 270     # isn't much we can do about it.
 271
 272    unless ($id) {
 273     if (wantarray) {
 274         return ( $id, $self->loc('Object could not be created') );
 275     }
 276     else {
 277         return ($id);
 278     }
 279
 280    }
 281
 282     if  (UNIVERSAL::isa('errno',$id)) {
 283         exit(0);
 284        warn "It's here!";
 285         return(undef);
 286     }
 287
 288     $self->Load($id) if ($id);
 289
 290
 291
 292     if (wantarray) {
 293         return ( $id, $self->loc('Object created') );
 294     }
 295     else {
 296         return ($id);
 297     }
 298
 299 }
 300
 301 # }}}
 302
 303 # {{{ sub LoadByCols
 304
 305 =head2 LoadByCols
 306
 307 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
 308 DB is case sensitive
 309
 310 =cut
 311
 312 sub LoadByCols {
 313     my $self = shift;
 314     my %hash = (@_);
 315
 316     # We don't want to hang onto this
 317     delete $self->{'attributes'};
 318
 319     # If this database is case sensitive we need to uncase objects for
 320     # explicit loading
 321     if ( $self->_Handle->CaseSensitive ) {
 322         my %newhash;
 323         foreach my $key ( keys %hash ) {
 324
 325             # If we've been passed an empty value, we can't do the lookup.
 326             # We don't need to explicitly downcase integers or an id.
 327             if ( $key =~ '^id$'
 328                 || !defined( $hash{$key} )
 329                 || $hash{$key} =~ /^\d+$/
 330                  )
 331             {
 332                 $newhash{$key} = $hash{$key};
 333             }
 334             else {
 335                 my ($op, $val);
 336                 ($key, $op, $val) = $self->_Handle->_MakeClauseCaseInsensitive($key, '=', $hash{$key});
 337                 $newhash{$key}->{operator} = $op;
 338                 $newhash{$key}->{value} = $val;
 339             }
 340         }
 341
 342         # We've clobbered everything we care about. bash the old hash
 343         # and replace it with the new hash
 344         %hash = %newhash;
 345     }
 346     $self->SUPER::LoadByCols(%hash);
 347 }
 348
 349 # }}}
 350
 351 # {{{ Datehandling
 352
 353 # There is room for optimizations in most of those subs:
 354
 355 # {{{ LastUpdatedObj
 356
 357 sub LastUpdatedObj {
 358     my $self = shift;
 359     my $obj  = new RT::Date( $self->CurrentUser );
 360
 361     $obj->Set( Format => 'sql', Value => $self->LastUpdated );
 362     return $obj;
 363 }
 364
 365 # }}}
 366
 367 # {{{ CreatedObj
 368
 369 sub CreatedObj {
 370     my $self = shift;
 371     my $obj  = new RT::Date( $self->CurrentUser );
 372
 373     $obj->Set( Format => 'sql', Value => $self->Created );
 374
 375     return $obj;
 376 }
 377
 378 # }}}
 379
 380 # {{{ AgeAsString
 381 #
 382 # TODO: This should be deprecated
 383 #
 384 sub AgeAsString {
 385     my $self = shift;
 386     return ( $self->CreatedObj->AgeAsString() );
 387 }
 388
 389 # }}}
 390
 391 # {{{ LastUpdatedAsString
 392
 393 # TODO this should be deprecated
 394
 395 sub LastUpdatedAsString {
 396     my $self = shift;
 397     if ( $self->LastUpdated ) {
 398         return ( $self->LastUpdatedObj->AsString() );
 399
 400     }
 401     else {
 402         return "never";
 403     }
 404 }
 405
 406 # }}}
 407
 408 # {{{ CreatedAsString
 409 #
 410 # TODO This should be deprecated
 411 #
 412 sub CreatedAsString {
 413     my $self = shift;
 414     return ( $self->CreatedObj->AsString() );
 415 }
 416
 417 # }}}
 418
 419 # {{{ LongSinceUpdateAsString
 420 #
 421 # TODO This should be deprecated
 422 #
 423 sub LongSinceUpdateAsString {
 424     my $self = shift;
 425     if ( $self->LastUpdated ) {
 426
 427         return ( $self->LastUpdatedObj->AgeAsString() );
 428
 429     }
 430     else {
 431         return "never";
 432     }
 433 }
 434
 435 # }}}
 436
 437 # }}} Datehandling
 438
 439 # {{{ sub _Set
 440 sub _Set {
 441     my $self = shift;
 442
 443     my %args = (
 444         Field => undef,
 445         Value => undef,
 446         IsSQL => undef,
 447         @_
 448     );
 449
 450     #if the user is trying to modify the record
 451     # TODO: document _why_ this code is here
 452
 453     if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
 454         $args{'Value'} = 0;
 455     }
 456
 457     $self->_SetLastUpdated();
 458     my ( $val, $msg ) = $self->SUPER::_Set(
 459         Field => $args{'Field'},
 460         Value => $args{'Value'},
 461         IsSQL => $args{'IsSQL'}
 462     );
 463 }
 464
 465 # }}}
 466
 467 # {{{ sub _SetLastUpdated
 468
 469 =head2 _SetLastUpdated
 470
 471 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
 472 It takes no options. Arguably, this is a bug
 473
 474 =cut
 475
 476 sub _SetLastUpdated {
 477     my $self = shift;
 478     use RT::Date;
 479     my $now = new RT::Date( $self->CurrentUser );
 480     $now->SetToNow();
 481
 482     if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
 483         my ( $msg, $val ) = $self->__Set(
 484             Field => 'LastUpdated',
 485             Value => $now->ISO
 486         );
 487     }
 488     if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
 489         my ( $msg, $val ) = $self->__Set(
 490             Field => 'LastUpdatedBy',
 491             Value => $self->CurrentUser->id
 492         );
 493     }
 494 }
 495
 496 # }}}
 497
 498 # {{{ sub CreatorObj
 499
 500 =head2 CreatorObj
 501
 502 Returns an RT::User object with the RT account of the creator of this row
 503
 504 =cut
 505
 506 sub CreatorObj {
 507     my $self = shift;
 508     unless ( exists $self->{'CreatorObj'} ) {
 509
 510         $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
 511         $self->{'CreatorObj'}->Load( $self->Creator );
 512     }
 513     return ( $self->{'CreatorObj'} );
 514 }
 515
 516 # }}}
 517
 518 # {{{ sub LastUpdatedByObj
 519
 520 =head2 LastUpdatedByObj
 521
 522   Returns an RT::User object of the last user to touch this object
 523
 524 =cut
 525
 526 sub LastUpdatedByObj {
 527     my $self = shift;
 528     unless ( exists $self->{LastUpdatedByObj} ) {
 529         $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
 530         $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
 531     }
 532     return $self->{'LastUpdatedByObj'};
 533 }
 534
 535 # }}}
 536
 537 # {{{ sub URI
 538
 539 =head2 URI
 540
 541 Returns this record's URI
 542
 543 =cut
 544
 545 sub URI {
 546     my $self = shift;
 547     my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
 548     return($uri->URIForObject($self));
 549 }
 550
 551 # }}}
 552
 553
 554
 555
 556
 557 =head2 SQLType attribute
 558
 559 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
 560
 561 =cut
 562
 563 sub SQLType {
 564     my $self = shift;
 565     my $field = shift;
 566
 567     return ($self->_Accessible($field, 'type'));
 568
 569
 570 }
 571
 572 require Encode::compat if $] < 5.007001;
 573 require Encode;
 574
 575
 576
 577
 578 sub __Value {
 579     my $self  = shift;
 580     my $field = shift;
 581     my %args = ( decode_utf8 => 1,
 582                  @_ );
 583
 584     unless (defined $field && $field) {
 585         $RT::Logger->error("$self __Value called with undef field");
 586     }
 587     my $value = $self->SUPER::__Value($field);
 588
 589     return('') if ( !defined($value) || $value eq '');
 590
 591     return Encode::decode_utf8($value) || $value if $args{'decode_utf8'};
 592     return $value;
 593 }
 594
 595 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
 596
 597 sub _CacheConfig {
 598   {
 599      'cache_p'        => 1,
 600      'cache_for_sec'  => 30,
 601   }
 602 }
 603
 604
 605
 606 sub _BuildTableAttributes {
 607     my $self = shift;
 608
 609     my $attributes;
 610     if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
 611        $attributes = $self->_CoreAccessible();
 612     } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
 613        $attributes = $self->_ClassAccessible();
 614
 615     }
 616
 617     foreach my $column (%$attributes) {
 618         foreach my $attr ( %{ $attributes->{$column} } ) {
 619             $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 620         }
 621     }
 622     if ( UNIVERSAL::can( $self, '_OverlayAccessible' ) ) {
 623         $attributes = $self->_OverlayAccessible();
 624
 625         foreach my $column (%$attributes) {
 626             foreach my $attr ( %{ $attributes->{$column} } ) {
 627                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 628             }
 629         }
 630     }
 631     if ( UNIVERSAL::can( $self, '_VendorAccessible' ) ) {
 632         $attributes = $self->_VendorAccessible();
 633
 634         foreach my $column (%$attributes) {
 635             foreach my $attr ( %{ $attributes->{$column} } ) {
 636                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 637             }
 638         }
 639     }
 640     if ( UNIVERSAL::can( $self, '_LocalAccessible' ) ) {
 641         $attributes = $self->_LocalAccessible();
 642
 643         foreach my $column (%$attributes) {
 644             foreach my $attr ( %{ $attributes->{$column} } ) {
 645                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 646             }
 647         }
 648     }
 649
 650 }
 651
 652
 653 =head2 _ClassAccessible
 654
 655 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
 656 DBIx::SearchBuilder::Record
 657
 658 =cut
 659
 660 sub _ClassAccessible {
 661     my $self = shift;
 662     return $_TABLE_ATTR->{ref($self)};
 663 }
 664
 665 =head2 _Accessible COLUMN ATTRIBUTE
 666
 667 returns the value of ATTRIBUTE for COLUMN
 668
 669
 670 =cut
 671
 672 sub _Accessible  {
 673   my $self = shift;
 674   my $column = shift;
 675   my $attribute = lc(shift);
 676   return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
 677   return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
 678
 679 }
 680
 681 =head2 _EncodeLOB BODY MIME_TYPE
 682
 683 Takes a potentially large attachment. Returns (ContentEncoding, EncodedBody) based on system configuration and selected database
 684
 685 =cut
 686
 687 sub _EncodeLOB {
 688         my $self = shift;
 689         my $Body = shift;
 690         my $MIMEType = shift;
 691
 692         my $ContentEncoding = 'none';
 693
 694         #get the max attachment length from RT
 695         my $MaxSize = $RT::MaxAttachmentSize;
 696
 697         #if the current attachment contains nulls and the
 698         #database doesn't support embedded nulls
 699
 700         if ( $RT::AlwaysUseBase64 or
 701              ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
 702
 703             # set a flag telling us to mimencode the attachment
 704             $ContentEncoding = 'base64';
 705
 706             #cut the max attchment size by 25% (for mime-encoding overhead.
 707             $RT::Logger->debug("Max size is $MaxSize\n");
 708             $MaxSize = $MaxSize * 3 / 4;
 709         # Some databases (postgres) can't handle non-utf8 data
 710         } elsif (    !$RT::Handle->BinarySafeBLOBs
 711                   && $MIMEType !~ /text\/plain/gi
 712                   && !Encode::is_utf8( $Body, 1 ) ) {
 713               $ContentEncoding = 'quoted-printable';
 714         }
 715
 716         #if the attachment is larger than the maximum size
 717         if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
 718
 719             # if we're supposed to truncate large attachments
 720             if ($RT::TruncateLongAttachments) {
 721
 722                 # truncate the attachment to that length.
 723                 $Body = substr( $Body, 0, $MaxSize );
 724
 725             }
 726
 727             # elsif we're supposed to drop large attachments on the floor,
 728             elsif ($RT::DropLongAttachments) {
 729
 730                 # drop the attachment on the floor
 731                 $RT::Logger->info( "$self: Dropped an attachment of size " . length($Body) . "\n" . "It started: " . substr( $Body, 0, 60 ) . "\n" );
 732                 return ("none", "Large attachment dropped" );
 733             }
 734         }
 735
 736         # if we need to mimencode the attachment
 737         if ( $ContentEncoding eq 'base64' ) {
 738
 739             # base64 encode the attachment
 740             Encode::_utf8_off($Body);
 741             $Body = MIME::Base64::encode_base64($Body);
 742
 743         } elsif ($ContentEncoding eq 'quoted-printable') {
 744             Encode::_utf8_off($Body);
 745             $Body = MIME::QuotedPrint::encode($Body);
 746         }
 747
 748
 749         return ($ContentEncoding, $Body);
 750
 751 }
 752
 753
 754 # {{{ LINKDIRMAP
 755 # A helper table for links mapping to make it easier
 756 # to build and parse links between tickets
 757
 758 use vars '%LINKDIRMAP';
 759
 760 %LINKDIRMAP = (
 761     MemberOf => { Base => 'MemberOf',
 762                   Target => 'HasMember', },
 763     RefersTo => { Base => 'RefersTo',
 764                 Target => 'ReferredToBy', },
 765     DependsOn => { Base => 'DependsOn',
 766                    Target => 'DependedOnBy', },
 767     MergedInto => { Base => 'MergedInto',
 768                    Target => 'MergedInto', },
 769
 770 );
 771
 772 sub Update {
 773     my $self = shift;
 774
 775     my %args = (
 776         ARGSRef         => undef,
 777         AttributesRef   => undef,
 778         AttributePrefix => undef,
 779         @_
 780     );
 781
 782     my $attributes = $args{'AttributesRef'};
 783     my $ARGSRef    = $args{'ARGSRef'};
 784     my @results;
 785
 786     foreach my $attribute (@$attributes) {
 787         my $value;
 788         if ( defined $ARGSRef->{$attribute} ) {
 789             $value = $ARGSRef->{$attribute};
 790         }
 791         elsif (
 792             defined( $args{'AttributePrefix'} )
 793             && defined(
 794                 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
 795             )
 796           )
 797         {
 798             $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
 799
 800         }
 801         else {
 802             next;
 803         }
 804
 805         $value =~ s/\r\n/\n/gs;
 806
 807
 808         # If Queue is 'General', we want to resolve the queue name for
 809         # the object.
 810
 811         # This is in an eval block because $object might not exist.
 812         # and might not have a Name method. But "can" won't find autoloaded
 813         # items. If it fails, we don't care
 814         eval {
 815             my $object = $attribute . "Obj";
 816             next if ($self->$object->Name eq $value);
 817         };
 818         next if ( $value eq $self->$attribute() );
 819         my $method = "Set$attribute";
 820         my ( $code, $msg ) = $self->$method($value);
 821
 822         my ($prefix) = ref($self) =~ /RT::(\w+)/;
 823         push @results,
 824           $self->loc( "$prefix [_1]", $self->id ) . ': '
 825           . $self->loc($attribute) . ': '
 826           . $self->CurrentUser->loc_fuzzy($msg);
 827
 828 =for loc
 829                                    "[_1] could not be set to [_2].",       # loc
 830                                    "That is already the current value",    # loc
 831                                    "No value sent to _Set!\n",             # loc
 832                                    "Illegal value for [_1]",               # loc
 833                                    "The new value has been set.",          # loc
 834                                    "No column specified",                  # loc
 835                                    "Immutable field",                      # loc
 836                                    "Nonexistant field?",                   # loc
 837                                    "Invalid data",                         # loc
 838                                    "Couldn't find row",                    # loc
 839                                    "Missing a primary key?: [_1]",         # loc
 840                                    "Found Object",                         # loc
 841 =cut
 842
 843     }
 844
 845     return @results;
 846 }
 847
 848 # {{{ Routines dealing with Links between tickets
 849
 850 # {{{ Link Collections
 851
 852 # {{{ sub Members
 853
 854 =head2 Members
 855
 856   This returns an RT::Links object which references all the tickets
 857 which are 'MembersOf' this ticket
 858
 859 =cut
 860
 861 sub Members {
 862     my $self = shift;
 863     return ( $self->_Links( 'Target', 'MemberOf' ) );
 864 }
 865
 866 # }}}
 867
 868 # {{{ sub MemberOf
 869
 870 =head2 MemberOf
 871
 872   This returns an RT::Links object which references all the tickets that this
 873 ticket is a 'MemberOf'
 874
 875 =cut
 876
 877 sub MemberOf {
 878     my $self = shift;
 879     return ( $self->_Links( 'Base', 'MemberOf' ) );
 880 }
 881
 882 # }}}
 883
 884 # {{{ RefersTo
 885
 886 =head2 RefersTo
 887
 888   This returns an RT::Links object which shows all references for which this ticket is a base
 889
 890 =cut
 891
 892 sub RefersTo {
 893     my $self = shift;
 894     return ( $self->_Links( 'Base', 'RefersTo' ) );
 895 }
 896
 897 # }}}
 898
 899 # {{{ ReferredToBy
 900
 901 =head2 ReferredToBy
 902
 903   This returns an RT::Links object which shows all references for which this ticket is a target
 904
 905 =cut
 906
 907 sub ReferredToBy {
 908     my $self = shift;
 909     return ( $self->_Links( 'Target', 'RefersTo' ) );
 910 }
 911
 912 # }}}
 913
 914 # {{{ DependedOnBy
 915
 916 =head2 DependedOnBy
 917
 918   This returns an RT::Links object which references all the tickets that depend on this one
 919
 920 =cut
 921
 922 sub DependedOnBy {
 923     my $self = shift;
 924     return ( $self->_Links( 'Target', 'DependsOn' ) );
 925 }
 926
 927 # }}}
 928
 929
 930
 931 =head2 HasUnresolvedDependencies
 932
 933   Takes a paramhash of Type (default to '__any').  Returns true if
 934 $self->UnresolvedDependencies returns an object with one or more members
 935 of that type.  Returns false otherwise
 936
 937
 938 =begin testing
 939
 940 my $t1 = RT::Ticket->new($RT::SystemUser);
 941 my ($id, $trans, $msg) = $t1->Create(Subject => 'DepTest1', Queue => 'general');
 942 ok($id, "Created dep test 1 - $msg");
 943
 944 my $t2 = RT::Ticket->new($RT::SystemUser);
 945 my ($id2, $trans, $msg2) = $t2->Create(Subject => 'DepTest2', Queue => 'general');
 946 ok($id2, "Created dep test 2 - $msg2");
 947 my $t3 = RT::Ticket->new($RT::SystemUser);
 948 my ($id3, $trans, $msg3) = $t3->Create(Subject => 'DepTest3', Queue => 'general', Type => 'approval');
 949 ok($id3, "Created dep test 3 - $msg3");
 950 my ($addid, $addmsg);
 951 ok (($addid, $addmsg) =$t1->AddLink( Type => 'DependsOn', Target => $t2->id));
 952 ok ($addid, $addmsg);
 953 ok (($addid, $addmsg) =$t1->AddLink( Type => 'DependsOn', Target => $t3->id));
 954
 955 ok ($addid, $addmsg);
 956 ok ($t1->HasUnresolvedDependencies, "Ticket ".$t1->Id." has unresolved deps");
 957 ok (!$t1->HasUnresolvedDependencies( Type => 'blah' ), "Ticket ".$t1->Id." has no unresolved blahs");
 958 ok ($t1->HasUnresolvedDependencies( Type => 'approval' ), "Ticket ".$t1->Id." has unresolved approvals");
 959 ok (!$t2->HasUnresolvedDependencies, "Ticket ".$t2->Id." has no unresolved deps");
 960 ;
 961
 962 my ($rid, $rmsg)= $t1->Resolve();
 963 ok(!$rid, $rmsg);
 964 ok($t2->Resolve);
 965 ($rid, $rmsg)= $t1->Resolve();
 966 ok(!$rid, $rmsg);
 967 ok($t3->Resolve);
 968 ($rid, $rmsg)= $t1->Resolve();
 969 ok($rid, $rmsg);
 970
 971
 972 =end testing
 973
 974 =cut
 975
 976 sub HasUnresolvedDependencies {
 977     my $self = shift;
 978     my %args = (
 979         Type   => undef,
 980         @_
 981     );
 982
 983     my $deps = $self->UnresolvedDependencies;
 984
 985     if ($args{Type}) {
 986         $deps->Limit( FIELD => 'Type',
 987               OPERATOR => '=',
 988               VALUE => $args{Type});
 989     }
 990     else {
 991             $deps->IgnoreType;
 992     }
 993
 994     if ($deps->Count > 0) {
 995         return 1;
 996     }
 997     else {
 998         return (undef);
 999     }
1000 }
1001
1002
1003 # {{{ UnresolvedDependencies
1004
1005 =head2 UnresolvedDependencies
1006
1007 Returns an RT::Tickets object of tickets which this ticket depends on
1008 and which have a status of new, open or stalled. (That list comes from
1009 RT::Queue->ActiveStatusArray
1010
1011 =cut
1012
1013
1014 sub UnresolvedDependencies {
1015     my $self = shift;
1016     my $deps = RT::Tickets->new($self->CurrentUser);
1017
1018     my @live_statuses = RT::Queue->ActiveStatusArray();
1019     foreach my $status (@live_statuses) {
1020         $deps->LimitStatus(VALUE => $status);
1021     }
1022     $deps->LimitDependedOnBy($self->Id);
1023
1024     return($deps);
1025
1026 }
1027
1028 # }}}
1029
1030 # {{{ AllDependedOnBy
1031
1032 =head2 AllDependedOnBy
1033
1034 Returns an array of RT::Ticket objects which (directly or indirectly)
1035 depends on this ticket; takes an optional 'Type' argument in the param
1036 hash, which will limit returned tickets to that type, as well as cause
1037 tickets with that type to serve as 'leaf' nodes that stops the recursive
1038 dependency search.
1039
1040 =cut
1041
1042 sub AllDependedOnBy {
1043     my $self = shift;
1044     my $dep = $self->DependedOnBy;
1045     my %args = (
1046         Type   => undef,
1047         _found => {},
1048         _top   => 1,
1049         @_
1050     );
1051
1052     while (my $link = $dep->Next()) {
1053         next unless ($link->BaseURI->IsLocal());
1054         next if $args{_found}{$link->BaseObj->Id};
1055
1056         if (!$args{Type}) {
1057             $args{_found}{$link->BaseObj->Id} = $link->BaseObj;
1058             $link->BaseObj->AllDependedOnBy( %args, _top => 0 );
1059         }
1060         elsif ($link->BaseObj->Type eq $args{Type}) {
1061             $args{_found}{$link->BaseObj->Id} = $link->BaseObj;
1062         }
1063         else {
1064             $link->BaseObj->AllDependedOnBy( %args, _top => 0 );
1065         }
1066     }
1067
1068     if ($args{_top}) {
1069         return map { $args{_found}{$_} } sort keys %{$args{_found}};
1070     }
1071     else {
1072         return 1;
1073     }
1074 }
1075
1076 # }}}
1077
1078 # {{{ DependsOn
1079
1080 =head2 DependsOn
1081
1082   This returns an RT::Links object which references all the tickets that this ticket depends on
1083
1084 =cut
1085
1086 sub DependsOn {
1087     my $self = shift;
1088     return ( $self->_Links( 'Base', 'DependsOn' ) );
1089 }
1090
1091 # }}}
1092
1093
1094
1095
1096 # {{{ sub _Links
1097
1098 sub _Links {
1099     my $self = shift;
1100
1101     #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1102     #tobias meant by $f
1103     my $field = shift;
1104     my $type  = shift || "";
1105
1106     unless ( $self->{"$field$type"} ) {
1107         $self->{"$field$type"} = new RT::Links( $self->CurrentUser );
1108             # at least to myself
1109             $self->{"$field$type"}->Limit( FIELD => $field,
1110                                            VALUE => $self->URI,
1111                                            ENTRYAGGREGATOR => 'OR' );
1112             $self->{"$field$type"}->Limit( FIELD => 'Type',
1113                                            VALUE => $type )
1114               if ($type);
1115     }
1116     return ( $self->{"$field$type"} );
1117 }
1118
1119 # }}}
1120
1121 # }}}
1122
1123 # {{{ sub _AddLink
1124
1125 =head2 _AddLink
1126
1127 Takes a paramhash of Type and one of Base or Target. Adds that link to this ticket.
1128
1129
1130 =cut
1131
1132
1133 sub _AddLink {
1134     my $self = shift;
1135     my %args = ( Target => '',
1136                  Base   => '',
1137                  Type   => '',
1138                  Silent => undef,
1139                  @_ );
1140
1141
1142     # Remote_link is the URI of the object that is not this ticket
1143     my $remote_link;
1144     my $direction;
1145
1146     if ( $args{'Base'} and $args{'Target'} ) {
1147         $RT::Logger->debug(
1148 "$self tried to delete a link. both base and target were specified\n" );
1149         return ( 0, $self->loc("Can't specifiy both base and target") );
1150     }
1151     elsif ( $args{'Base'} ) {
1152         $args{'Target'} = $self->URI();
1153         my $class = ref($self);
1154         $remote_link    = $args{'Base'};
1155         $direction      = 'Target';
1156     }
1157     elsif ( $args{'Target'} ) {
1158         $args{'Base'} = $self->URI();
1159         my $class = ref($self);
1160         $remote_link  = $args{'Target'};
1161         $direction    = 'Base';
1162     }
1163     else {
1164         return ( 0, $self->loc('Either base or target must be specified') );
1165     }
1166
1167     # {{{ Check if the link already exists - we don't want duplicates
1168     use RT::Link;
1169     my $old_link = RT::Link->new( $self->CurrentUser );
1170     $old_link->LoadByParams( Base   => $args{'Base'},
1171                              Type   => $args{'Type'},
1172                              Target => $args{'Target'} );
1173     if ( $old_link->Id ) {
1174         $RT::Logger->debug("$self Somebody tried to duplicate a link");
1175         return ( $old_link->id, $self->loc("Link already exists"), 0 );
1176     }
1177
1178     # }}}
1179
1180
1181     # Storing the link in the DB.
1182     my $link = RT::Link->new( $self->CurrentUser );
1183     my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1184                                   Base   => $args{Base},
1185                                   Type   => $args{Type} );
1186
1187     unless ($linkid) {
1188         $RT::Logger->error("Link could not be created: ".$linkmsg);
1189         return ( 0, $self->loc("Link could not be created") );
1190     }
1191
1192     my $TransString =
1193       "Record $args{'Base'} $args{Type} record $args{'Target'}.";
1194
1195     return ( 1, $self->loc( "Link created ([_1])", $TransString ) );
1196 }
1197
1198 # }}}
1199
1200 # {{{ sub _DeleteLink
1201
1202 =head2 _DeleteLink
1203
1204 Delete a link. takes a paramhash of Base, Target and Type.
1205 Either Base or Target must be null. The null value will
1206 be replaced with this ticket\'s id
1207
1208 =cut
1209
1210 sub _DeleteLink {
1211     my $self = shift;
1212     my %args = (
1213         Base   => undef,
1214         Target => undef,
1215         Type   => undef,
1216         @_
1217     );
1218
1219     #we want one of base and target. we don't care which
1220     #but we only want _one_
1221
1222     my $direction;
1223     my $remote_link;
1224
1225     if ( $args{'Base'} and $args{'Target'} ) {
1226         $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target\n");
1227         return ( 0, $self->loc("Can't specifiy both base and target") );
1228     }
1229     elsif ( $args{'Base'} ) {
1230         $args{'Target'} = $self->URI();
1231         $remote_link = $args{'Base'};
1232         $direction = 'Target';
1233     }
1234     elsif ( $args{'Target'} ) {
1235         $args{'Base'} = $self->URI();
1236         $remote_link = $args{'Target'};
1237         $direction='Base';
1238     }
1239     else {
1240         $RT::Logger->debug("$self: Base or Target must be specified\n");
1241         return ( 0, $self->loc('Either base or target must be specified') );
1242     }
1243
1244     my $link = new RT::Link( $self->CurrentUser );
1245     $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} . "\n" );
1246
1247
1248     $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=>  $args{'Target'} );
1249     #it's a real link.
1250     if ( $link->id ) {
1251
1252         my $linkid = $link->id;
1253         $link->Delete();
1254
1255         my $TransString = "Record $args{'Base'} no longer $args{Type} record $args{'Target'}.";
1256         return ( 1, $self->loc("Link deleted ([_1])", $TransString));
1257     }
1258
1259     #if it's not a link we can find
1260     else {
1261         $RT::Logger->debug("Couldn't find that link\n");
1262         return ( 0, $self->loc("Link not found") );
1263     }
1264 }
1265
1266 # }}}
1267
1268 eval "require RT::Record_Vendor";
1269 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Vendor.pm});
1270 eval "require RT::Record_Local";
1271 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Local.pm});
1272
1273 1;