rt/lib/RT/Record.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 =head1 NAME
  49
  50   RT::Record - Base class for RT record objects
  51
  52 =head1 SYNOPSIS
  53
  54
  55 =head1 DESCRIPTION
  56
  57
  58 =begin testing
  59
  60 ok (require RT::Record);
  61
  62 =end testing
  63
  64 =head1 METHODS
  65
  66 =cut
  67
  68 package RT::Record;
  69
  70 use strict;
  71 use warnings;
  72
  73 our @ISA;
  74 use base qw(RT::Base);
  75
  76 use RT::Date;
  77 use RT::I18N;
  78 use RT::User;
  79 use RT::Attributes;
  80 use DBIx::SearchBuilder::Record::Cachable;
  81 use Encode qw();
  82
  83 our $_TABLE_ATTR = { };
  84
  85
  86 if ( $RT::DontCacheSearchBuilderRecords ) {
  87     push (@ISA, 'DBIx::SearchBuilder::Record');
  88 } else {
  89     push (@ISA, 'DBIx::SearchBuilder::Record::Cachable');
  90
  91 }
  92
  93 # {{{ sub _Init
  94
  95 sub _Init {
  96     my $self = shift;
  97     $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
  98     $self->CurrentUser(@_);
  99 }
 100
 101 # }}}
 102
 103 # {{{ _PrimaryKeys
 104
 105 =head2 _PrimaryKeys
 106
 107 The primary keys for RT classes is 'id'
 108
 109 =cut
 110
 111 sub _PrimaryKeys {
 112     my $self = shift;
 113     return ( ['id'] );
 114 }
 115
 116 # }}}
 117
 118 =head2 Delete
 119
 120 Delete this record object from the database.
 121
 122 =cut
 123
 124 sub Delete {
 125     my $self = shift;
 126     my ($rv) = $self->SUPER::Delete;
 127     if ($rv) {
 128         return ($rv, $self->loc("Object deleted"));
 129     } else {
 130
 131         return(0, $self->loc("Object could not be deleted"))
 132     }
 133 }
 134
 135 =head2 ObjectTypeStr
 136
 137 Returns a string which is this object's type.  The type is the class,
 138 without the "RT::" prefix.
 139
 140 =begin testing
 141
 142 my $ticket = RT::Ticket->new($RT::SystemUser);
 143 my $group = RT::Group->new($RT::SystemUser);
 144 is($ticket->ObjectTypeStr, 'Ticket', "Ticket returns correct typestring");
 145 is($group->ObjectTypeStr, 'Group', "Group returns correct typestring");
 146
 147 =end testing
 148
 149 =cut
 150
 151 sub ObjectTypeStr {
 152     my $self = shift;
 153     if (ref($self) =~ /^.*::(\w+)$/) {
 154         return $self->loc($1);
 155     } else {
 156         return $self->loc(ref($self));
 157     }
 158 }
 159
 160 =head2 Attributes
 161
 162 Return this object's attributes as an RT::Attributes object
 163
 164 =cut
 165
 166 sub Attributes {
 167     my $self = shift;
 168
 169     unless ($self->{'attributes'}) {
 170         $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
 171        $self->{'attributes'}->LimitToObject($self);
 172     }
 173     return ($self->{'attributes'});
 174
 175 }
 176
 177
 178 =head2 AddAttribute { Name, Description, Content }
 179
 180 Adds a new attribute for this object.
 181
 182 =cut
 183
 184 sub AddAttribute {
 185     my $self = shift;
 186     my %args = ( Name        => undef,
 187                  Description => undef,
 188                  Content     => undef,
 189                  @_ );
 190
 191     my $attr = RT::Attribute->new( $self->CurrentUser );
 192     my ( $id, $msg ) = $attr->Create(
 193                                       Object    => $self,
 194                                       Name        => $args{'Name'},
 195                                       Description => $args{'Description'},
 196                                       Content     => $args{'Content'} );
 197
 198
 199     # XXX TODO: Why won't RedoSearch work here?
 200     $self->Attributes->_DoSearch;
 201
 202     return ($id, $msg);
 203 }
 204
 205
 206 =head2 SetAttribute { Name, Description, Content }
 207
 208 Like AddAttribute, but replaces all existing attributes with the same Name.
 209
 210 =cut
 211
 212 sub SetAttribute {
 213     my $self = shift;
 214     my %args = ( Name        => undef,
 215                  Description => undef,
 216                  Content     => undef,
 217                  @_ );
 218
 219     my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
 220         or return $self->AddAttribute( %args );
 221
 222     my $AttributeObj = pop( @AttributeObjs );
 223     $_->Delete foreach @AttributeObjs;
 224
 225     $AttributeObj->SetDescription( $args{'Description'} );
 226     $AttributeObj->SetContent( $args{'Content'} );
 227
 228     $self->Attributes->RedoSearch;
 229     return 1;
 230 }
 231
 232 =head2 DeleteAttribute NAME
 233
 234 Deletes all attributes with the matching name for this object.
 235
 236 =cut
 237
 238 sub DeleteAttribute {
 239     my $self = shift;
 240     my $name = shift;
 241     return $self->Attributes->DeleteEntry( Name => $name );
 242 }
 243
 244 =head2 FirstAttribute NAME
 245
 246 Returns the first attribute with the matching name for this object (as an
 247 L<RT::Attribute> object), or C<undef> if no such attributes exist.
 248
 249 Note that if there is more than one attribute with the matching name on the
 250 object, the choice of which one to return is basically arbitrary.  This may be
 251 made well-defined in the future.
 252
 253 =cut
 254
 255 sub FirstAttribute {
 256     my $self = shift;
 257     my $name = shift;
 258     return ($self->Attributes->Named( $name ))[0];
 259 }
 260
 261
 262 # {{{ sub _Handle
 263 sub _Handle {
 264     my $self = shift;
 265     return ($RT::Handle);
 266 }
 267
 268 # }}}
 269
 270 # {{{ sub Create
 271
 272 =head2  Create PARAMHASH
 273
 274 Takes a PARAMHASH of Column -> Value pairs.
 275 If any Column has a Validate$PARAMNAME subroutine defined and the
 276 value provided doesn't pass validation, this routine returns
 277 an error.
 278
 279 If this object's table has any of the following atetributes defined as
 280 'Auto', this routine will automatically fill in their values.
 281
 282 =cut
 283
 284 sub Create {
 285     my $self    = shift;
 286     my %attribs = (@_);
 287     foreach my $key ( keys %attribs ) {
 288         my $method = "Validate$key";
 289         unless ( $self->$method( $attribs{$key} ) ) {
 290             if (wantarray) {
 291                 return ( 0, $self->loc('Invalid value for [_1]', $key) );
 292             }
 293             else {
 294                 return (0);
 295             }
 296         }
 297     }
 298     my $now = RT::Date->new( $self->CurrentUser );
 299     $now->Set( Format => 'unix', Value => time );
 300     $attribs{'Created'} = $now->ISO() if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
 301
 302     if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
 303          $attribs{'Creator'} = $self->CurrentUser->id || '0';
 304     }
 305     $attribs{'LastUpdated'} = $now->ISO()
 306       if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
 307
 308     $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
 309       if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
 310
 311     my $id = $self->SUPER::Create(%attribs);
 312     if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
 313         if ( $id->errno ) {
 314             if (wantarray) {
 315                 return ( 0,
 316                     $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
 317             }
 318             else {
 319                 return (0);
 320             }
 321         }
 322     }
 323     # If the object was created in the database,
 324     # load it up now, so we're sure we get what the database
 325     # has.  Arguably, this should not be necessary, but there
 326     # isn't much we can do about it.
 327
 328    unless ($id) {
 329     if (wantarray) {
 330         return ( $id, $self->loc('Object could not be created') );
 331     }
 332     else {
 333         return ($id);
 334     }
 335
 336    }
 337
 338     if  (UNIVERSAL::isa('errno',$id)) {
 339         exit(0);
 340        warn "It's here!";
 341         return(undef);
 342     }
 343
 344     $self->Load($id) if ($id);
 345
 346
 347
 348     if (wantarray) {
 349         return ( $id, $self->loc('Object created') );
 350     }
 351     else {
 352         return ($id);
 353     }
 354
 355 }
 356
 357 # }}}
 358
 359 # {{{ sub LoadByCols
 360
 361 =head2 LoadByCols
 362
 363 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
 364 DB is case sensitive
 365
 366 =cut
 367
 368 sub LoadByCols {
 369     my $self = shift;
 370     my %hash = (@_);
 371
 372     # We don't want to hang onto this
 373     delete $self->{'attributes'};
 374
 375     # If this database is case sensitive we need to uncase objects for
 376     # explicit loading
 377     if ( $self->_Handle->CaseSensitive ) {
 378         my %newhash;
 379         foreach my $key ( keys %hash ) {
 380
 381             # If we've been passed an empty value, we can't do the lookup.
 382             # We don't need to explicitly downcase integers or an id.
 383             if ( $key =~ '^id$'
 384                 || !defined( $hash{$key} )
 385                 || $hash{$key} =~ /^\d+$/
 386                  )
 387             {
 388                 $newhash{$key} = $hash{$key};
 389             }
 390             else {
 391                 my ($op, $val, $func);
 392                 ($key, $op, $val, $func) = $self->_Handle->_MakeClauseCaseInsensitive($key, '=', $hash{$key});
 393                 $newhash{$key}->{operator} = $op;
 394                 $newhash{$key}->{value} = $val;
 395                 $newhash{$key}->{function} = $func;
 396             }
 397         }
 398
 399         # We've clobbered everything we care about. bash the old hash
 400         # and replace it with the new hash
 401         %hash = %newhash;
 402     }
 403     $self->SUPER::LoadByCols(%hash);
 404 }
 405
 406 # }}}
 407
 408 # {{{ Datehandling
 409
 410 # There is room for optimizations in most of those subs:
 411
 412 # {{{ LastUpdatedObj
 413
 414 sub LastUpdatedObj {
 415     my $self = shift;
 416     my $obj  = new RT::Date( $self->CurrentUser );
 417
 418     $obj->Set( Format => 'sql', Value => $self->LastUpdated );
 419     return $obj;
 420 }
 421
 422 # }}}
 423
 424 # {{{ CreatedObj
 425
 426 sub CreatedObj {
 427     my $self = shift;
 428     my $obj  = new RT::Date( $self->CurrentUser );
 429
 430     $obj->Set( Format => 'sql', Value => $self->Created );
 431
 432     return $obj;
 433 }
 434
 435 # }}}
 436
 437 # {{{ AgeAsString
 438 #
 439 # TODO: This should be deprecated
 440 #
 441 sub AgeAsString {
 442     my $self = shift;
 443     return ( $self->CreatedObj->AgeAsString() );
 444 }
 445
 446 # }}}
 447
 448 # {{{ LastUpdatedAsString
 449
 450 # TODO this should be deprecated
 451
 452 sub LastUpdatedAsString {
 453     my $self = shift;
 454     if ( $self->LastUpdated ) {
 455         return ( $self->LastUpdatedObj->AsString() );
 456
 457     }
 458     else {
 459         return "never";
 460     }
 461 }
 462
 463 # }}}
 464
 465 # {{{ CreatedAsString
 466 #
 467 # TODO This should be deprecated
 468 #
 469 sub CreatedAsString {
 470     my $self = shift;
 471     return ( $self->CreatedObj->AsString() );
 472 }
 473
 474 # }}}
 475
 476 # {{{ LongSinceUpdateAsString
 477 #
 478 # TODO This should be deprecated
 479 #
 480 sub LongSinceUpdateAsString {
 481     my $self = shift;
 482     if ( $self->LastUpdated ) {
 483
 484         return ( $self->LastUpdatedObj->AgeAsString() );
 485
 486     }
 487     else {
 488         return "never";
 489     }
 490 }
 491
 492 # }}}
 493
 494 # }}} Datehandling
 495
 496 # {{{ sub _Set
 497 #
 498 sub _Set {
 499     my $self = shift;
 500
 501     my %args = (
 502         Field => undef,
 503         Value => undef,
 504         IsSQL => undef,
 505         @_
 506     );
 507
 508     #if the user is trying to modify the record
 509     # TODO: document _why_ this code is here
 510
 511     if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
 512         $args{'Value'} = 0;
 513     }
 514
 515     my $old_val = $self->__Value($args{'Field'});
 516      $self->_SetLastUpdated();
 517     my $ret = $self->SUPER::_Set(
 518         Field => $args{'Field'},
 519         Value => $args{'Value'},
 520         IsSQL => $args{'IsSQL'}
 521     );
 522         my ($status, $msg) =  $ret->as_array();
 523
 524         # @values has two values, a status code and a message.
 525
 526     # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
 527     # we want to change the standard "success" message
 528     if ($status) {
 529         $msg =
 530           $self->loc(
 531             "[_1] changed from [_2] to [_3]",
 532             $args{'Field'},
 533             ( $old_val ? "'$old_val'" : $self->loc("(no value)") ),
 534             '"' . $self->__Value( $args{'Field'}) . '"'
 535           );
 536       } else {
 537
 538           $msg = $self->CurrentUser->loc_fuzzy($msg);
 539     }
 540     return wantarray ? ($status, $msg) : $ret;
 541
 542 }
 543
 544 # }}}
 545
 546 # {{{ sub _SetLastUpdated
 547
 548 =head2 _SetLastUpdated
 549
 550 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
 551 It takes no options. Arguably, this is a bug
 552
 553 =cut
 554
 555 sub _SetLastUpdated {
 556     my $self = shift;
 557     use RT::Date;
 558     my $now = new RT::Date( $self->CurrentUser );
 559     $now->SetToNow();
 560
 561     if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
 562         my ( $msg, $val ) = $self->__Set(
 563             Field => 'LastUpdated',
 564             Value => $now->ISO
 565         );
 566     }
 567     if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
 568         my ( $msg, $val ) = $self->__Set(
 569             Field => 'LastUpdatedBy',
 570             Value => $self->CurrentUser->id
 571         );
 572     }
 573 }
 574
 575 # }}}
 576
 577 # {{{ sub CreatorObj
 578
 579 =head2 CreatorObj
 580
 581 Returns an RT::User object with the RT account of the creator of this row
 582
 583 =cut
 584
 585 sub CreatorObj {
 586     my $self = shift;
 587     unless ( exists $self->{'CreatorObj'} ) {
 588
 589         $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
 590         $self->{'CreatorObj'}->Load( $self->Creator );
 591     }
 592     return ( $self->{'CreatorObj'} );
 593 }
 594
 595 # }}}
 596
 597 # {{{ sub LastUpdatedByObj
 598
 599 =head2 LastUpdatedByObj
 600
 601   Returns an RT::User object of the last user to touch this object
 602
 603 =cut
 604
 605 sub LastUpdatedByObj {
 606     my $self = shift;
 607     unless ( exists $self->{LastUpdatedByObj} ) {
 608         $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
 609         $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
 610     }
 611     return $self->{'LastUpdatedByObj'};
 612 }
 613
 614 # }}}
 615
 616 # {{{ sub URI
 617
 618 =head2 URI
 619
 620 Returns this record's URI
 621
 622 =cut
 623
 624 sub URI {
 625     my $self = shift;
 626     my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
 627     return($uri->URIForObject($self));
 628 }
 629
 630 # }}}
 631
 632 =head2 ValidateName NAME
 633
 634 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
 635
 636 =cut
 637
 638 sub ValidateName {
 639     my $self = shift;
 640     my $value = shift;
 641     if ($value && $value=~ /^\d+$/) {
 642         return(0);
 643     } else  {
 644          return (1);
 645     }
 646 }
 647
 648
 649
 650 =head2 SQLType attribute
 651
 652 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
 653
 654 =cut
 655
 656 sub SQLType {
 657     my $self = shift;
 658     my $field = shift;
 659
 660     return ($self->_Accessible($field, 'type'));
 661
 662
 663 }
 664
 665
 666 sub __Value {
 667     my $self  = shift;
 668     my $field = shift;
 669     my %args = ( decode_utf8 => 1,
 670                  @_ );
 671
 672     unless (defined $field && $field) {
 673         $RT::Logger->error("$self __Value called with undef field");
 674     }
 675     my $value = $self->SUPER::__Value($field);
 676
 677     return('') if ( !defined($value) || $value eq '');
 678
 679     if( $args{'decode_utf8'} ) {
 680         # XXX: is_utf8 check should be here unless Encode bug would be fixed
 681         # see http://rt.cpan.org/NoAuth/Bug.html?id=14559
 682         return Encode::decode_utf8($value) unless Encode::is_utf8($value);
 683     } else {
 684         # check is_utf8 here just to be shure
 685         return Encode::encode_utf8($value) if Encode::is_utf8($value);
 686     }
 687     return $value;
 688 }
 689
 690 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
 691
 692 sub _CacheConfig {
 693   {
 694      'cache_p'        => 1,
 695      'cache_for_sec'  => 30,
 696   }
 697 }
 698
 699
 700
 701 sub _BuildTableAttributes {
 702     my $self = shift;
 703
 704     my $attributes;
 705     if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
 706        $attributes = $self->_CoreAccessible();
 707     } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
 708        $attributes = $self->_ClassAccessible();
 709
 710     }
 711
 712     foreach my $column (%$attributes) {
 713         foreach my $attr ( %{ $attributes->{$column} } ) {
 714             $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 715         }
 716     }
 717     if ( UNIVERSAL::can( $self, '_OverlayAccessible' ) ) {
 718         $attributes = $self->_OverlayAccessible();
 719
 720         foreach my $column (%$attributes) {
 721             foreach my $attr ( %{ $attributes->{$column} } ) {
 722                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 723             }
 724         }
 725     }
 726     if ( UNIVERSAL::can( $self, '_VendorAccessible' ) ) {
 727         $attributes = $self->_VendorAccessible();
 728
 729         foreach my $column (%$attributes) {
 730             foreach my $attr ( %{ $attributes->{$column} } ) {
 731                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 732             }
 733         }
 734     }
 735     if ( UNIVERSAL::can( $self, '_LocalAccessible' ) ) {
 736         $attributes = $self->_LocalAccessible();
 737
 738         foreach my $column (%$attributes) {
 739             foreach my $attr ( %{ $attributes->{$column} } ) {
 740                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 741             }
 742         }
 743     }
 744
 745 }
 746
 747
 748 =head2 _ClassAccessible
 749
 750 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
 751 DBIx::SearchBuilder::Record
 752
 753 =cut
 754
 755 sub _ClassAccessible {
 756     my $self = shift;
 757     return $_TABLE_ATTR->{ref($self)};
 758 }
 759
 760 =head2 _Accessible COLUMN ATTRIBUTE
 761
 762 returns the value of ATTRIBUTE for COLUMN
 763
 764
 765 =cut
 766
 767 sub _Accessible  {
 768   my $self = shift;
 769   my $column = shift;
 770   my $attribute = lc(shift);
 771   return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
 772   return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
 773
 774 }
 775
 776 =head2 _EncodeLOB BODY MIME_TYPE
 777
 778 Takes a potentially large attachment. Returns (ContentEncoding, EncodedBody) based on system configuration and selected database
 779
 780 =cut
 781
 782 sub _EncodeLOB {
 783         my $self = shift;
 784         my $Body = shift;
 785         my $MIMEType = shift;
 786
 787         my $ContentEncoding = 'none';
 788
 789         #get the max attachment length from RT
 790         my $MaxSize = $RT::MaxAttachmentSize;
 791
 792         #if the current attachment contains nulls and the
 793         #database doesn't support embedded nulls
 794
 795         if ( $RT::AlwaysUseBase64 or
 796              ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
 797
 798             # set a flag telling us to mimencode the attachment
 799             $ContentEncoding = 'base64';
 800
 801             #cut the max attchment size by 25% (for mime-encoding overhead.
 802             $RT::Logger->debug("Max size is $MaxSize\n");
 803             $MaxSize = $MaxSize * 3 / 4;
 804         # Some databases (postgres) can't handle non-utf8 data
 805         } elsif (    !$RT::Handle->BinarySafeBLOBs
 806                   && $MIMEType !~ /text\/plain/gi
 807                   && !Encode::is_utf8( $Body, 1 ) ) {
 808               $ContentEncoding = 'quoted-printable';
 809         }
 810
 811         #if the attachment is larger than the maximum size
 812         if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
 813
 814             # if we're supposed to truncate large attachments
 815             if ($RT::TruncateLongAttachments) {
 816
 817                 # truncate the attachment to that length.
 818                 $Body = substr( $Body, 0, $MaxSize );
 819
 820             }
 821
 822             # elsif we're supposed to drop large attachments on the floor,
 823             elsif ($RT::DropLongAttachments) {
 824
 825                 # drop the attachment on the floor
 826                 $RT::Logger->info( "$self: Dropped an attachment of size "
 827                                    . length($Body) . "\n"
 828                                    . "It started: " . substr( $Body, 0, 60 ) . "\n"
 829                                  );
 830                 return ("none", "Large attachment dropped" );
 831             }
 832         }
 833
 834         # if we need to mimencode the attachment
 835         if ( $ContentEncoding eq 'base64' ) {
 836
 837             # base64 encode the attachment
 838             Encode::_utf8_off($Body);
 839             $Body = MIME::Base64::encode_base64($Body);
 840
 841         } elsif ($ContentEncoding eq 'quoted-printable') {
 842             Encode::_utf8_off($Body);
 843             $Body = MIME::QuotedPrint::encode($Body);
 844         }
 845
 846
 847         return ($ContentEncoding, $Body);
 848
 849 }
 850
 851 sub _DecodeLOB {
 852     my $self            = shift;
 853     my $ContentType     = shift;
 854     my $ContentEncoding = shift;
 855     my $Content         = shift;
 856
 857     if ( $ContentEncoding eq 'base64' ) {
 858         $Content = MIME::Base64::decode_base64($Content);
 859     }
 860     elsif ( $ContentEncoding eq 'quoted-printable' ) {
 861         $Content = MIME::QuotedPrint::decode($Content);
 862     }
 863     elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
 864         return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
 865     }
 866
 867     if ( RT::I18N::IsTextualContentType($ContentType) ) {
 868        $Content = Encode::decode_utf8($Content) unless Encode::is_utf8($Content);
 869     }
 870         return ($Content);
 871 }
 872
 873 # {{{ LINKDIRMAP
 874 # A helper table for links mapping to make it easier
 875 # to build and parse links between tickets
 876
 877 use vars '%LINKDIRMAP';
 878
 879 %LINKDIRMAP = (
 880     MemberOf => { Base => 'MemberOf',
 881                   Target => 'HasMember', },
 882     RefersTo => { Base => 'RefersTo',
 883                 Target => 'ReferredToBy', },
 884     DependsOn => { Base => 'DependsOn',
 885                    Target => 'DependedOnBy', },
 886     MergedInto => { Base => 'MergedInto',
 887                    Target => 'MergedInto', },
 888
 889 );
 890
 891 =head2 Update  ARGSHASH
 892
 893 Updates fields on an object for you using the proper Set methods,
 894 skipping unchanged values.
 895
 896  ARGSRef => a hashref of attributes => value for the update
 897  AttributesRef => an arrayref of keys in ARGSRef that should be updated
 898  AttributePrefix => a prefix that should be added to the attributes in AttributesRef
 899                     when looking up values in ARGSRef
 900                     Bare attributes are tried before prefixed attributes
 901
 902 Returns a list of localized results of the update
 903
 904 =cut
 905
 906 sub Update {
 907     my $self = shift;
 908
 909     my %args = (
 910         ARGSRef         => undef,
 911         AttributesRef   => undef,
 912         AttributePrefix => undef,
 913         @_
 914     );
 915
 916     my $attributes = $args{'AttributesRef'};
 917     my $ARGSRef    = $args{'ARGSRef'};
 918     my @results;
 919
 920     foreach my $attribute (@$attributes) {
 921         my $value;
 922         if ( defined $ARGSRef->{$attribute} ) {
 923             $value = $ARGSRef->{$attribute};
 924         }
 925         elsif (
 926             defined( $args{'AttributePrefix'} )
 927             && defined(
 928                 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
 929             )
 930           ) {
 931             $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
 932
 933         }
 934         else {
 935             next;
 936         }
 937
 938         $value =~ s/\r\n/\n/gs;
 939
 940
 941         # If Queue is 'General', we want to resolve the queue name for
 942         # the object.
 943
 944         # This is in an eval block because $object might not exist.
 945         # and might not have a Name method. But "can" won't find autoloaded
 946         # items. If it fails, we don't care
 947         eval {
 948             my $object = $attribute . "Obj";
 949             next if ($self->$object->Name eq $value);
 950         };
 951         next if ( $value eq $self->$attribute() );
 952         my $method = "Set$attribute";
 953         my ( $code, $msg ) = $self->$method($value);
 954         my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
 955
 956         # Default to $id, but use name if we can get it.
 957         my $label = $self->id;
 958         $label = $self->Name if (UNIVERSAL::can($self,'Name'));
 959         push @results, $self->loc( "$prefix [_1]", $label ) . ': '. $msg;
 960
 961 =for loc
 962
 963                                    "[_1] could not be set to [_2].",       # loc
 964                                    "That is already the current value",    # loc
 965                                    "No value sent to _Set!\n",             # loc
 966                                    "Illegal value for [_1]",               # loc
 967                                    "The new value has been set.",          # loc
 968                                    "No column specified",                  # loc
 969                                    "Immutable field",                      # loc
 970                                    "Nonexistant field?",                   # loc
 971                                    "Invalid data",                         # loc
 972                                    "Couldn't find row",                    # loc
 973                                    "Missing a primary key?: [_1]",         # loc
 974                                    "Found Object",                         # loc
 975
 976 =cut
 977
 978     }
 979
 980     return @results;
 981 }
 982
 983 # {{{ Routines dealing with Links
 984
 985 # {{{ Link Collections
 986
 987 # {{{ sub Members
 988
 989 =head2 Members
 990
 991   This returns an RT::Links object which references all the tickets
 992 which are 'MembersOf' this ticket
 993
 994 =cut
 995
 996 sub Members {
 997     my $self = shift;
 998     return ( $self->_Links( 'Target', 'MemberOf' ) );
 999 }
1000
1001 # }}}
1002
1003 # {{{ sub MemberOf
1004
1005 =head2 MemberOf
1006
1007   This returns an RT::Links object which references all the tickets that this
1008 ticket is a 'MemberOf'
1009
1010 =cut
1011
1012 sub MemberOf {
1013     my $self = shift;
1014     return ( $self->_Links( 'Base', 'MemberOf' ) );
1015 }
1016
1017 # }}}
1018
1019 # {{{ RefersTo
1020
1021 =head2 RefersTo
1022
1023   This returns an RT::Links object which shows all references for which this ticket is a base
1024
1025 =cut
1026
1027 sub RefersTo {
1028     my $self = shift;
1029     return ( $self->_Links( 'Base', 'RefersTo' ) );
1030 }
1031
1032 # }}}
1033
1034 # {{{ ReferredToBy
1035
1036 =head2 ReferredToBy
1037
1038 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1039
1040 =cut
1041
1042 sub ReferredToBy {
1043     my $self = shift;
1044     return ( $self->_Links( 'Target', 'RefersTo' ) );
1045 }
1046
1047 # }}}
1048
1049 # {{{ DependedOnBy
1050
1051 =head2 DependedOnBy
1052
1053   This returns an RT::Links object which references all the tickets that depend on this one
1054
1055 =cut
1056
1057 sub DependedOnBy {
1058     my $self = shift;
1059     return ( $self->_Links( 'Target', 'DependsOn' ) );
1060 }
1061
1062 # }}}
1063
1064
1065
1066 =head2 HasUnresolvedDependencies
1067
1068   Takes a paramhash of Type (default to '__any').  Returns true if
1069 $self->UnresolvedDependencies returns an object with one or more members
1070 of that type.  Returns false otherwise
1071
1072
1073 =begin testing
1074
1075 my $t1 = RT::Ticket->new($RT::SystemUser);
1076 my ($id, $trans, $msg) = $t1->Create(Subject => 'DepTest1', Queue => 'general');
1077 ok($id, "Created dep test 1 - $msg");
1078
1079 my $t2 = RT::Ticket->new($RT::SystemUser);
1080 my ($id2, $trans, $msg2) = $t2->Create(Subject => 'DepTest2', Queue => 'general');
1081 ok($id2, "Created dep test 2 - $msg2");
1082 my $t3 = RT::Ticket->new($RT::SystemUser);
1083 my ($id3, $trans, $msg3) = $t3->Create(Subject => 'DepTest3', Queue => 'general', Type => 'approval');
1084 ok($id3, "Created dep test 3 - $msg3");
1085 my ($addid, $addmsg);
1086 ok (($addid, $addmsg) =$t1->AddLink( Type => 'DependsOn', Target => $t2->id));
1087 ok ($addid, $addmsg);
1088 ok (($addid, $addmsg) =$t1->AddLink( Type => 'DependsOn', Target => $t3->id));
1089
1090 ok ($addid, $addmsg);
1091 my $link = RT::Link->new($RT::SystemUser);
1092 my ($rv, $msg) = $link->Load($addid);
1093 ok ($rv, $msg);
1094 ok ($link->LocalTarget == $t3->id, "Link LocalTarget is correct");
1095 ok ($link->LocalBase   == $t1->id, "Link LocalBase   is correct");
1096
1097 ok ($t1->HasUnresolvedDependencies, "Ticket ".$t1->Id." has unresolved deps");
1098 ok (!$t1->HasUnresolvedDependencies( Type => 'blah' ), "Ticket ".$t1->Id." has no unresolved blahs");
1099 ok ($t1->HasUnresolvedDependencies( Type => 'approval' ), "Ticket ".$t1->Id." has unresolved approvals");
1100 ok (!$t2->HasUnresolvedDependencies, "Ticket ".$t2->Id." has no unresolved deps");
1101 ;
1102
1103 my ($rid, $rmsg)= $t1->Resolve();
1104 ok(!$rid, $rmsg);
1105 my ($rid2, $rmsg2) = $t2->Resolve();
1106 ok ($rid2, $rmsg2);
1107 ($rid, $rmsg)= $t1->Resolve();
1108 ok(!$rid, $rmsg);
1109 my ($rid3,$rmsg3) = $t3->Resolve;
1110 ok ($rid3,$rmsg3);
1111 ($rid, $rmsg)= $t1->Resolve();
1112 ok($rid, $rmsg);
1113
1114
1115 =end testing
1116
1117 =cut
1118
1119 sub HasUnresolvedDependencies {
1120     my $self = shift;
1121     my %args = (
1122         Type   => undef,
1123         @_
1124     );
1125
1126     my $deps = $self->UnresolvedDependencies;
1127
1128     if ($args{Type}) {
1129         $deps->Limit( FIELD => 'Type',
1130               OPERATOR => '=',
1131               VALUE => $args{Type});
1132     }
1133     else {
1134             $deps->IgnoreType;
1135     }
1136
1137     if ($deps->Count > 0) {
1138         return 1;
1139     }
1140     else {
1141         return (undef);
1142     }
1143 }
1144
1145
1146 # {{{ UnresolvedDependencies
1147
1148 =head2 UnresolvedDependencies
1149
1150 Returns an RT::Tickets object of tickets which this ticket depends on
1151 and which have a status of new, open or stalled. (That list comes from
1152 RT::Queue->ActiveStatusArray
1153
1154 =cut
1155
1156
1157 sub UnresolvedDependencies {
1158     my $self = shift;
1159     my $deps = RT::Tickets->new($self->CurrentUser);
1160
1161     my @live_statuses = RT::Queue->ActiveStatusArray();
1162     foreach my $status (@live_statuses) {
1163         $deps->LimitStatus(VALUE => $status);
1164     }
1165     $deps->LimitDependedOnBy($self->Id);
1166
1167     return($deps);
1168
1169 }
1170
1171 # }}}
1172
1173 # {{{ AllDependedOnBy
1174
1175 =head2 AllDependedOnBy
1176
1177 Returns an array of RT::Ticket objects which (directly or indirectly)
1178 depends on this ticket; takes an optional 'Type' argument in the param
1179 hash, which will limit returned tickets to that type, as well as cause
1180 tickets with that type to serve as 'leaf' nodes that stops the recursive
1181 dependency search.
1182
1183 =cut
1184
1185 sub AllDependedOnBy {
1186     my $self = shift;
1187     my $dep = $self->DependedOnBy;
1188     my %args = (
1189         Type   => undef,
1190         _found => {},
1191         _top   => 1,
1192         @_
1193     );
1194
1195     while (my $link = $dep->Next()) {
1196         next unless ($link->BaseURI->IsLocal());
1197         next if $args{_found}{$link->BaseObj->Id};
1198
1199         if (!$args{Type}) {
1200             $args{_found}{$link->BaseObj->Id} = $link->BaseObj;
1201             $link->BaseObj->AllDependedOnBy( %args, _top => 0 );
1202         }
1203         elsif ($link->BaseObj->Type eq $args{Type}) {
1204             $args{_found}{$link->BaseObj->Id} = $link->BaseObj;
1205         }
1206         else {
1207             $link->BaseObj->AllDependedOnBy( %args, _top => 0 );
1208         }
1209     }
1210
1211     if ($args{_top}) {
1212         return map { $args{_found}{$_} } sort keys %{$args{_found}};
1213     }
1214     else {
1215         return 1;
1216     }
1217 }
1218
1219 # }}}
1220
1221 # {{{ DependsOn
1222
1223 =head2 DependsOn
1224
1225   This returns an RT::Links object which references all the tickets that this ticket depends on
1226
1227 =cut
1228
1229 sub DependsOn {
1230     my $self = shift;
1231     return ( $self->_Links( 'Base', 'DependsOn' ) );
1232 }
1233
1234 # }}}
1235
1236 # {{{ Customers
1237
1238 =head2 Customers
1239
1240   This returns an RT::Links object which references all the customers that this object is a member of.
1241
1242 =cut
1243
1244 sub Customers {
1245     my( $self, %opt ) = @_;
1246     my $Debug = $opt{'Debug'};
1247
1248     unless ( $self->{'Customers'} ) {
1249
1250       $self->{'Customers'} = $self->MemberOf->Clone;
1251
1252       $self->{'Customers'}->Limit(
1253                                    FIELD    => 'Target',
1254                                    OPERATOR => 'STARTSWITH',
1255                                    VALUE    => 'freeside://freeside/cust_main/',
1256                                  );
1257     }
1258
1259     warn "->Customers method called on $self; returning ".
1260          ref($self->{'Customers'}). ' object'
1261       if $Debug;
1262
1263     return $self->{'Customers'};
1264 }
1265
1266 # }}}
1267
1268 # {{{ sub _Links
1269
1270 =head2 Links DIRECTION [TYPE]
1271
1272 Return links (L<RT::Links>) to/from this object.
1273
1274 DIRECTION is either 'Base' or 'Target'.
1275
1276 TYPE is a type of links to return, it can be omitted to get
1277 links of any type.
1278
1279 =cut
1280
1281 *Links = \&_Links;
1282
1283 sub _Links {
1284     my $self = shift;
1285
1286     #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1287     #tobias meant by $f
1288     my $field = shift;
1289     my $type  = shift || "";
1290
1291     unless ( $self->{"$field$type"} ) {
1292         $self->{"$field$type"} = new RT::Links( $self->CurrentUser );
1293             # at least to myself
1294             $self->{"$field$type"}->Limit( FIELD => $field,
1295                                            VALUE => $self->URI,
1296                                            ENTRYAGGREGATOR => 'OR' );
1297             $self->{"$field$type"}->Limit( FIELD => 'Type',
1298                                            VALUE => $type )
1299               if ($type);
1300     }
1301     return ( $self->{"$field$type"} );
1302 }
1303
1304 # }}}
1305
1306 # }}}
1307
1308 # {{{ sub _AddLink
1309
1310 =head2 _AddLink
1311
1312 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1313
1314 Returns C<link id>, C<message> and C<exist> flag.
1315
1316
1317 =cut
1318
1319
1320 sub _AddLink {
1321     my $self = shift;
1322     my %args = ( Target => '',
1323                  Base   => '',
1324                  Type   => '',
1325                  Silent => undef,
1326                  @_ );
1327
1328
1329     # Remote_link is the URI of the object that is not this ticket
1330     my $remote_link;
1331     my $direction;
1332
1333     if ( $args{'Base'} and $args{'Target'} ) {
1334         $RT::Logger->debug( "$self tried to create a link. both base and target were specified\n" );
1335         return ( 0, $self->loc("Can't specifiy both base and target") );
1336     }
1337     elsif ( $args{'Base'} ) {
1338         $args{'Target'} = $self->URI();
1339         $remote_link    = $args{'Base'};
1340         $direction      = 'Target';
1341     }
1342     elsif ( $args{'Target'} ) {
1343         $args{'Base'} = $self->URI();
1344         $remote_link  = $args{'Target'};
1345         $direction    = 'Base';
1346     }
1347     else {
1348         return ( 0, $self->loc('Either base or target must be specified') );
1349     }
1350
1351     # {{{ Check if the link already exists - we don't want duplicates
1352     use RT::Link;
1353     my $old_link = RT::Link->new( $self->CurrentUser );
1354     $old_link->LoadByParams( Base   => $args{'Base'},
1355                              Type   => $args{'Type'},
1356                              Target => $args{'Target'} );
1357     if ( $old_link->Id ) {
1358         $RT::Logger->debug("$self Somebody tried to duplicate a link");
1359         return ( $old_link->id, $self->loc("Link already exists"), 1 );
1360     }
1361
1362     # }}}
1363
1364
1365     # Storing the link in the DB.
1366     my $link = RT::Link->new( $self->CurrentUser );
1367     my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1368                                   Base   => $args{Base},
1369                                   Type   => $args{Type} );
1370
1371     unless ($linkid) {
1372         $RT::Logger->error("Link could not be created: ".$linkmsg);
1373         return ( 0, $self->loc("Link could not be created") );
1374     }
1375
1376     my $TransString =
1377       "Record $args{'Base'} $args{Type} record $args{'Target'}.";
1378
1379     return ( $linkid, $self->loc( "Link created ([_1])", $TransString ) );
1380 }
1381
1382 # }}}
1383
1384 # {{{ sub _DeleteLink
1385
1386 =head2 _DeleteLink
1387
1388 Delete a link. takes a paramhash of Base, Target and Type.
1389 Either Base or Target must be null. The null value will
1390 be replaced with this ticket\'s id
1391
1392 =cut
1393
1394 sub _DeleteLink {
1395     my $self = shift;
1396     my %args = (
1397         Base   => undef,
1398         Target => undef,
1399         Type   => undef,
1400         @_
1401     );
1402
1403     #we want one of base and target. we don't care which
1404     #but we only want _one_
1405
1406     my $direction;
1407     my $remote_link;
1408
1409     if ( $args{'Base'} and $args{'Target'} ) {
1410         $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target\n");
1411         return ( 0, $self->loc("Can't specifiy both base and target") );
1412     }
1413     elsif ( $args{'Base'} ) {
1414         $args{'Target'} = $self->URI();
1415         $remote_link = $args{'Base'};
1416         $direction = 'Target';
1417     }
1418     elsif ( $args{'Target'} ) {
1419         $args{'Base'} = $self->URI();
1420         $remote_link = $args{'Target'};
1421         $direction='Base';
1422     }
1423     else {
1424         $RT::Logger->error("Base or Target must be specified\n");
1425         return ( 0, $self->loc('Either base or target must be specified') );
1426     }
1427
1428     my $link = new RT::Link( $self->CurrentUser );
1429     $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} . "\n" );
1430
1431
1432     $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=>  $args{'Target'} );
1433     #it's a real link.
1434     if ( $link->id ) {
1435
1436         my $linkid = $link->id;
1437         $link->Delete();
1438
1439         my $TransString = "Record $args{'Base'} no longer $args{Type} record $args{'Target'}.";
1440         return ( 1, $self->loc("Link deleted ([_1])", $TransString));
1441     }
1442
1443     #if it's not a link we can find
1444     else {
1445         $RT::Logger->debug("Couldn't find that link\n");
1446         return ( 0, $self->loc("Link not found") );
1447     }
1448 }
1449
1450 # }}}
1451
1452 # }}}
1453
1454 # {{{ Routines dealing with transactions
1455
1456 # {{{ sub _NewTransaction
1457
1458 =head2 _NewTransaction  PARAMHASH
1459
1460 Private function to create a new RT::Transaction object for this ticket update
1461
1462 =cut
1463
1464 sub _NewTransaction {
1465     my $self = shift;
1466     my %args = (
1467         TimeTaken => undef,
1468         Type      => undef,
1469         OldValue  => undef,
1470         NewValue  => undef,
1471         OldReference  => undef,
1472         NewReference  => undef,
1473         ReferenceType => undef,
1474         Data      => undef,
1475         Field     => undef,
1476         MIMEObj   => undef,
1477         ActivateScrips => 1,
1478         CommitScrips => 1,
1479         @_
1480     );
1481
1482     my $old_ref = $args{'OldReference'};
1483     my $new_ref = $args{'NewReference'};
1484     my $ref_type = $args{'ReferenceType'};
1485     if ($old_ref or $new_ref) {
1486         $ref_type ||= ref($old_ref) || ref($new_ref);
1487         if (!$ref_type) {
1488             $RT::Logger->error("Reference type not specified for transaction");
1489             return;
1490         }
1491         $old_ref = $old_ref->Id if ref($old_ref);
1492         $new_ref = $new_ref->Id if ref($new_ref);
1493     }
1494
1495     require RT::Transaction;
1496     my $trans = new RT::Transaction( $self->CurrentUser );
1497     my ( $transaction, $msg ) = $trans->Create(
1498         ObjectId  => $self->Id,
1499         ObjectType => ref($self),
1500         TimeTaken => $args{'TimeTaken'},
1501         Type      => $args{'Type'},
1502         Data      => $args{'Data'},
1503         Field     => $args{'Field'},
1504         NewValue  => $args{'NewValue'},
1505         OldValue  => $args{'OldValue'},
1506         NewReference  => $new_ref,
1507         OldReference  => $old_ref,
1508         ReferenceType => $ref_type,
1509         MIMEObj   => $args{'MIMEObj'},
1510         ActivateScrips => $args{'ActivateScrips'},
1511         CommitScrips => $args{'CommitScrips'},
1512     );
1513
1514     # Rationalize the object since we may have done things to it during the caching.
1515     $self->Load($self->Id);
1516
1517     $RT::Logger->warning($msg) unless $transaction;
1518
1519     $self->_SetLastUpdated;
1520
1521     if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1522         $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1523     }
1524     if ( $RT::UseTransactionBatch and $transaction ) {
1525             push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1526     }
1527     return ( $transaction, $msg, $trans );
1528 }
1529
1530 # }}}
1531
1532 # {{{ sub Transactions
1533
1534 =head2 Transactions
1535
1536   Returns an RT::Transactions object of all transactions on this record object
1537
1538 =cut
1539
1540 sub Transactions {
1541     my $self = shift;
1542
1543     use RT::Transactions;
1544     my $transactions = RT::Transactions->new( $self->CurrentUser );
1545
1546     #If the user has no rights, return an empty object
1547     $transactions->Limit(
1548         FIELD => 'ObjectId',
1549         VALUE => $self->id,
1550     );
1551     $transactions->Limit(
1552         FIELD => 'ObjectType',
1553         VALUE => ref($self),
1554     );
1555
1556     return ($transactions);
1557 }
1558
1559 # }}}
1560 # }}}
1561 #
1562 # {{{ Routines dealing with custom fields
1563
1564 sub CustomFields {
1565     my $self = shift;
1566     my $cfs  = RT::CustomFields->new( $self->CurrentUser );
1567
1568     # XXX handle multiple types properly
1569     $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1570     $cfs->LimitToGlobalOrObjectId(
1571         $self->_LookupId( $self->CustomFieldLookupType ) );
1572
1573     return $cfs;
1574 }
1575
1576 # TODO: This _only_ works for RT::Class classes. it doesn't work, for example, for RT::FM classes.
1577
1578 sub _LookupId {
1579     my $self = shift;
1580     my $lookup = shift;
1581     my @classes = ($lookup =~ /RT::(\w+)-/g);
1582
1583     my $object = $self;
1584     foreach my $class (reverse @classes) {
1585         my $method = "${class}Obj";
1586         $object = $object->$method;
1587     }
1588
1589     return $object->Id;
1590 }
1591
1592
1593 =head2 CustomFieldLookupType
1594
1595 Returns the path RT uses to figure out which custom fields apply to this object.
1596
1597 =cut
1598
1599 sub CustomFieldLookupType {
1600     my $self = shift;
1601     return ref($self);
1602 }
1603
1604 #TODO Deprecated API. Destroy in 3.6
1605 sub _LookupTypes {
1606     my  $self = shift;
1607     $RT::Logger->warning("_LookupTypes call is deprecated at (". join(":",caller)."). Replace with CustomFieldLookupType");
1608
1609     return($self->CustomFieldLookupType);
1610
1611 }
1612
1613 # {{{ AddCustomFieldValue
1614
1615 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1616
1617 VALUE should be a string.
1618 FIELD can be a CustomField object OR a CustomField ID.
1619
1620
1621 Adds VALUE as a value of CustomField FIELD.  If this is a single-value custom field,
1622 deletes the old value.
1623 If VALUE is not a valid value for the custom field, returns
1624 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1625
1626 =cut
1627
1628 sub AddCustomFieldValue {
1629     my $self = shift;
1630     $self->_AddCustomFieldValue(@_);
1631 }
1632
1633 sub _AddCustomFieldValue {
1634     my $self = shift;
1635     my %args = (
1636         Field             => undef,
1637         Value             => undef,
1638         RecordTransaction => 1,
1639         @_
1640     );
1641
1642     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1643
1644     unless ( $cf->Id ) {
1645         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1646     }
1647
1648     my $OCFs = $self->CustomFields;
1649     $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1650     unless ( $OCFs->Count ) {
1651         return (
1652             0,
1653             $self->loc(
1654                 "Custom field [_1] does not apply to this object",
1655                 $args{'Field'}
1656             )
1657         );
1658     }
1659     # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1660     my $values = $cf->ValuesForObject($self);
1661
1662     unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1663         return ( 0, $self->loc("Invalid value for custom field") );
1664     }
1665
1666     # If the custom field only accepts a certain # of values, delete the existing
1667     # value and record a "changed from foo to bar" transaction
1668     unless ( $cf->UnlimitedValues) {
1669
1670  # We need to whack any old values here.  In most cases, the custom field should
1671  # only have one value to delete.  In the pathalogical case, this custom field
1672  # used to be a multiple and we have many values to whack....
1673         my $cf_values = $values->Count;
1674
1675         if ( $cf_values > $cf->MaxValues ) {
1676             my $i = 0;   #We want to delete all but the max we can currently have , so we can then
1677                  # execute the same code to "change" the value from old to new
1678             while ( my $value = $values->Next ) {
1679                 $i++;
1680                 if ( $i < $cf_values ) {
1681                     my ( $val, $msg ) = $cf->DeleteValueForObject(
1682                         Object  => $self,
1683                         Content => $value->Content
1684                     );
1685                     unless ($val) {
1686                         return ( 0, $msg );
1687                     }
1688                     my ( $TransactionId, $Msg, $TransactionObj ) =
1689                       $self->_NewTransaction(
1690                         Type         => 'CustomField',
1691                         Field        => $cf->Id,
1692                         OldReference => $value,
1693                       );
1694                 }
1695             }
1696             $values->RedoSearch if $i; # redo search if have deleted at least one value
1697         }
1698
1699         my ( $old_value, $old_content );
1700         if ( $old_value = $values->First ) {
1701             $old_content = $old_value->Content();
1702             return (1) if( $old_content eq $args{'Value'} && $old_value->LargeContent eq $args{'LargeContent'});;
1703         }
1704
1705         my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1706             Object       => $self,
1707             Content      => $args{'Value'},
1708             LargeContent => $args{'LargeContent'},
1709             ContentType  => $args{'ContentType'},
1710         );
1711
1712         unless ($new_value_id) {
1713             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg) );
1714         }
1715
1716         my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1717         $new_value->Load($new_value_id);
1718
1719         # now that adding the new value was successful, delete the old one
1720         if ($old_value) {
1721             my ( $val, $msg ) = $old_value->Delete();
1722             unless ($val) {
1723                 return ( 0, $msg );
1724             }
1725         }
1726
1727         if ( $args{'RecordTransaction'} ) {
1728             my ( $TransactionId, $Msg, $TransactionObj ) =
1729               $self->_NewTransaction(
1730                 Type         => 'CustomField',
1731                 Field        => $cf->Id,
1732                 OldReference => $old_value,
1733                 NewReference => $new_value,
1734               );
1735         }
1736
1737         if ( $old_value eq '' ) {
1738             return ( 1, $self->loc( "[_1] [_2] added", $cf->Name, $new_value->Content ));
1739         }
1740         elsif ( $new_value->Content eq '' ) {
1741             return ( 1,
1742                 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_value->Content ) );
1743         }
1744         else {
1745             return ( 1, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content,                $new_value->Content));
1746         }
1747
1748     }
1749
1750     # otherwise, just add a new value and record "new value added"
1751     else {
1752         my ($new_value_id, $value_msg) = $cf->AddValueForObject(
1753             Object       => $self,
1754             Content      => $args{'Value'},
1755             LargeContent => $args{'LargeContent'},
1756             ContentType  => $args{'ContentType'},
1757         );
1758
1759         unless ($new_value_id) {
1760             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg) );
1761         }
1762         if ( $args{'RecordTransaction'} ) {
1763             my ( $TransactionId, $Msg, $TransactionObj ) =
1764               $self->_NewTransaction(
1765                 Type          => 'CustomField',
1766                 Field         => $cf->Id,
1767                 NewReference  => $new_value_id,
1768                 ReferenceType => 'RT::ObjectCustomFieldValue',
1769               );
1770             unless ($TransactionId) {
1771                 return ( 0,
1772                     $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1773             }
1774         }
1775         return ( 1, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name));
1776     }
1777
1778 }
1779
1780 # }}}
1781
1782 # {{{ DeleteCustomFieldValue
1783
1784 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1785
1786 Deletes VALUE as a value of CustomField FIELD.
1787
1788 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1789
1790 If VALUE is not a valid value for the custom field, returns
1791 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1792
1793 =cut
1794
1795 sub DeleteCustomFieldValue {
1796     my $self = shift;
1797     my %args = (
1798         Field   => undef,
1799         Value   => undef,
1800         ValueId => undef,
1801         @_
1802     );
1803
1804     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1805
1806     unless ( $cf->Id ) {
1807         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1808     }
1809     my ( $val, $msg ) = $cf->DeleteValueForObject(
1810         Object  => $self,
1811         Id      => $args{'ValueId'},
1812         Content => $args{'Value'},
1813     );
1814     unless ($val) {
1815         return ( 0, $msg );
1816     }
1817     my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1818         Type          => 'CustomField',
1819         Field         => $cf->Id,
1820         OldReference  => $val,
1821         ReferenceType => 'RT::ObjectCustomFieldValue',
1822     );
1823     unless ($TransactionId) {
1824         return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1825     }
1826
1827     return (
1828         $TransactionId,
1829         $self->loc(
1830             "[_1] is no longer a value for custom field [_2]",
1831             $TransactionObj->OldValue, $cf->Name
1832         )
1833     );
1834 }
1835
1836 # }}}
1837
1838 # {{{ FirstCustomFieldValue
1839
1840 =head2 FirstCustomFieldValue FIELD
1841
1842 Return the content of the first value of CustomField FIELD for this ticket
1843 Takes a field id or name
1844
1845 =cut
1846
1847 sub FirstCustomFieldValue {
1848     my $self = shift;
1849     my $field = shift;
1850     my $values = $self->CustomFieldValues($field);
1851     if ($values->First) {
1852         return $values->First->Content;
1853     } else {
1854         return undef;
1855     }
1856
1857 }
1858
1859
1860
1861 # {{{ CustomFieldValues
1862
1863 =head2 CustomFieldValues FIELD
1864
1865 Return a ObjectCustomFieldValues object of all values of the CustomField whose
1866 id or Name is FIELD for this record.
1867
1868 Returns an RT::ObjectCustomFieldValues object
1869
1870 =cut
1871
1872 sub CustomFieldValues {
1873     my $self  = shift;
1874     my $field = shift;
1875
1876     if ($field) {
1877         my $cf = $self->LoadCustomFieldByIdentifier($field);
1878
1879         # we were asked to search on a custom field we couldn't fine
1880         unless ( $cf->id ) {
1881             return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1882         }
1883         return ( $cf->ValuesForObject($self) );
1884     }
1885
1886     # we're not limiting to a specific custom field;
1887     my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1888     $ocfs->LimitToObject($self);
1889     return $ocfs;
1890
1891 }
1892
1893 =head2 CustomField IDENTIFER
1894
1895 Find the custom field has id or name IDENTIFIER for this object.
1896
1897 If no valid field is found, returns an empty RT::CustomField object.
1898
1899 =cut
1900
1901 sub LoadCustomFieldByIdentifier {
1902     my $self = shift;
1903     my $field = shift;
1904
1905     my $cf = RT::CustomField->new($self->CurrentUser);
1906
1907     if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
1908         $cf->LoadById( $field->id );
1909     }
1910     elsif ($field =~ /^\d+$/) {
1911         $cf = RT::CustomField->new($self->CurrentUser);
1912         $cf->Load($field);
1913     } else {
1914
1915         my $cfs = $self->CustomFields($self->CurrentUser);
1916         $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
1917         $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
1918     }
1919     return $cf;
1920 }
1921
1922
1923 # }}}
1924
1925 # }}}
1926
1927 # }}}
1928
1929 sub BasicColumns {
1930 }
1931
1932 sub WikiBase {
1933   return $RT::WebPath. "/index.html?q=";
1934 }
1935
1936 eval "require RT::Record_Vendor";
1937 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Vendor.pm});
1938 eval "require RT::Record_Local";
1939 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Local.pm});
1940
1941 1;