rt/lib/RT/Record.pm

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