rt/lib/RT/Record.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2012 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         $msg =
 505           $self->loc(
 506             "[_1] changed from [_2] to [_3]",
 507             $self->loc( $args{'Field'} ),
 508             ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ),
 509             '"' . $self->__Value( $args{'Field'}) . '"'
 510           );
 511       } else {
 512
 513           $msg = $self->CurrentUser->loc_fuzzy($msg);
 514     }
 515     return wantarray ? ($status, $msg) : $ret;
 516
 517 }
 518
 519
 520
 521 =head2 _SetLastUpdated
 522
 523 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
 524 It takes no options. Arguably, this is a bug
 525
 526 =cut
 527
 528 sub _SetLastUpdated {
 529     my $self = shift;
 530     use RT::Date;
 531     my $now = RT::Date->new( $self->CurrentUser );
 532     $now->SetToNow();
 533
 534     if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
 535         my ( $msg, $val ) = $self->__Set(
 536             Field => 'LastUpdated',
 537             Value => $now->ISO
 538         );
 539     }
 540     if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
 541         my ( $msg, $val ) = $self->__Set(
 542             Field => 'LastUpdatedBy',
 543             Value => $self->CurrentUser->id
 544         );
 545     }
 546 }
 547
 548
 549
 550 =head2 CreatorObj
 551
 552 Returns an RT::User object with the RT account of the creator of this row
 553
 554 =cut
 555
 556 sub CreatorObj {
 557     my $self = shift;
 558     unless ( exists $self->{'CreatorObj'} ) {
 559
 560         $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
 561         $self->{'CreatorObj'}->Load( $self->Creator );
 562     }
 563     return ( $self->{'CreatorObj'} );
 564 }
 565
 566
 567
 568 =head2 LastUpdatedByObj
 569
 570   Returns an RT::User object of the last user to touch this object
 571
 572 =cut
 573
 574 sub LastUpdatedByObj {
 575     my $self = shift;
 576     unless ( exists $self->{LastUpdatedByObj} ) {
 577         $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
 578         $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
 579     }
 580     return $self->{'LastUpdatedByObj'};
 581 }
 582
 583
 584
 585 =head2 URI
 586
 587 Returns this record's URI
 588
 589 =cut
 590
 591 sub URI {
 592     my $self = shift;
 593     my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
 594     return($uri->URIForObject($self));
 595 }
 596
 597
 598 =head2 ValidateName NAME
 599
 600 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
 601
 602 =cut
 603
 604 sub ValidateName {
 605     my $self = shift;
 606     my $value = shift;
 607     if (defined $value && $value=~ /^\d+$/) {
 608         return(0);
 609     } else  {
 610         return(1);
 611     }
 612 }
 613
 614
 615
 616 =head2 SQLType attribute
 617
 618 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
 619
 620 =cut
 621
 622 sub SQLType {
 623     my $self = shift;
 624     my $field = shift;
 625
 626     return ($self->_Accessible($field, 'type'));
 627
 628
 629 }
 630
 631 sub __Value {
 632     my $self  = shift;
 633     my $field = shift;
 634     my %args  = ( decode_utf8 => 1, @_ );
 635
 636     unless ($field) {
 637         $RT::Logger->error("__Value called with undef field");
 638     }
 639
 640     my $value = $self->SUPER::__Value($field);
 641
 642     return undef if (!defined $value);
 643
 644     if ( $args{'decode_utf8'} ) {
 645         if ( !utf8::is_utf8($value) ) {
 646             utf8::decode($value);
 647         }
 648     }
 649     else {
 650         if ( utf8::is_utf8($value) ) {
 651             utf8::encode($value);
 652         }
 653     }
 654
 655     return $value;
 656
 657 }
 658
 659 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
 660
 661 sub _CacheConfig {
 662   {
 663      'cache_p'        => 1,
 664      'cache_for_sec'  => 30,
 665   }
 666 }
 667
 668
 669
 670 sub _BuildTableAttributes {
 671     my $self = shift;
 672     my $class = ref($self) || $self;
 673
 674     my $attributes;
 675     if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
 676        $attributes = $self->_CoreAccessible();
 677     } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
 678        $attributes = $self->_ClassAccessible();
 679
 680     }
 681
 682     foreach my $column (keys %$attributes) {
 683         foreach my $attr ( keys %{ $attributes->{$column} } ) {
 684             $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 685         }
 686     }
 687     foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
 688         next unless UNIVERSAL::can( $self, $method );
 689         $attributes = $self->$method();
 690
 691         foreach my $column ( keys %$attributes ) {
 692             foreach my $attr ( keys %{ $attributes->{$column} } ) {
 693                 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 694             }
 695         }
 696     }
 697 }
 698
 699
 700 =head2 _ClassAccessible
 701
 702 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
 703 DBIx::SearchBuilder::Record
 704
 705 =cut
 706
 707 sub _ClassAccessible {
 708     my $self = shift;
 709     return $_TABLE_ATTR->{ref($self) || $self};
 710 }
 711
 712 =head2 _Accessible COLUMN ATTRIBUTE
 713
 714 returns the value of ATTRIBUTE for COLUMN
 715
 716
 717 =cut
 718
 719 sub _Accessible  {
 720   my $self = shift;
 721   my $column = shift;
 722   my $attribute = lc(shift);
 723   return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
 724   return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
 725
 726 }
 727
 728 =head2 _EncodeLOB BODY MIME_TYPE
 729
 730 Takes a potentially large attachment. Returns (ContentEncoding, EncodedBody) based on system configuration and selected database
 731
 732 =cut
 733
 734 sub _EncodeLOB {
 735         my $self = shift;
 736         my $Body = shift;
 737         my $MIMEType = shift || '';
 738         my $Filename = shift;
 739
 740         my $ContentEncoding = 'none';
 741
 742         #get the max attachment length from RT
 743         my $MaxSize = RT->Config->Get('MaxAttachmentSize');
 744
 745         #if the current attachment contains nulls and the
 746         #database doesn't support embedded nulls
 747
 748         if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
 749
 750             # set a flag telling us to mimencode the attachment
 751             $ContentEncoding = 'base64';
 752
 753             #cut the max attchment size by 25% (for mime-encoding overhead.
 754             $RT::Logger->debug("Max size is $MaxSize");
 755             $MaxSize = $MaxSize * 3 / 4;
 756         # Some databases (postgres) can't handle non-utf8 data
 757         } elsif (    !$RT::Handle->BinarySafeBLOBs
 758                   && $MIMEType !~ /text\/plain/gi
 759                   && !Encode::is_utf8( $Body, 1 ) ) {
 760               $ContentEncoding = 'quoted-printable';
 761         }
 762
 763         #if the attachment is larger than the maximum size
 764         if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
 765
 766             # if we're supposed to truncate large attachments
 767             if (RT->Config->Get('TruncateLongAttachments')) {
 768
 769                 # truncate the attachment to that length.
 770                 $Body = substr( $Body, 0, $MaxSize );
 771
 772             }
 773
 774             # elsif we're supposed to drop large attachments on the floor,
 775             elsif (RT->Config->Get('DropLongAttachments')) {
 776
 777                 # drop the attachment on the floor
 778                 $RT::Logger->info( "$self: Dropped an attachment of size "
 779                                    . length($Body));
 780                 $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
 781                 $Filename .= ".txt" if $Filename;
 782                 return ("none", "Large attachment dropped", "plain/text", $Filename );
 783             }
 784         }
 785
 786         # if we need to mimencode the attachment
 787         if ( $ContentEncoding eq 'base64' ) {
 788
 789             # base64 encode the attachment
 790             Encode::_utf8_off($Body);
 791             $Body = MIME::Base64::encode_base64($Body);
 792
 793         } elsif ($ContentEncoding eq 'quoted-printable') {
 794             Encode::_utf8_off($Body);
 795             $Body = MIME::QuotedPrint::encode($Body);
 796         }
 797
 798
 799         return ($ContentEncoding, $Body, $MIMEType, $Filename );
 800
 801 }
 802
 803 sub _DecodeLOB {
 804     my $self            = shift;
 805     my $ContentType     = shift || '';
 806     my $ContentEncoding = shift || 'none';
 807     my $Content         = shift;
 808
 809     if ( $ContentEncoding eq 'base64' ) {
 810         $Content = MIME::Base64::decode_base64($Content);
 811     }
 812     elsif ( $ContentEncoding eq 'quoted-printable' ) {
 813         $Content = MIME::QuotedPrint::decode($Content);
 814     }
 815     elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
 816         return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
 817     }
 818     if ( RT::I18N::IsTextualContentType($ContentType) ) {
 819        $Content = Encode::decode_utf8($Content) unless Encode::is_utf8($Content);
 820     }
 821         return ($Content);
 822 }
 823
 824 # A helper table for links mapping to make it easier
 825 # to build and parse links between tickets
 826
 827 use vars '%LINKDIRMAP';
 828
 829 %LINKDIRMAP = (
 830     MemberOf => { Base => 'MemberOf',
 831                   Target => 'HasMember', },
 832     RefersTo => { Base => 'RefersTo',
 833                 Target => 'ReferredToBy', },
 834     DependsOn => { Base => 'DependsOn',
 835                    Target => 'DependedOnBy', },
 836     MergedInto => { Base => 'MergedInto',
 837                    Target => 'MergedInto', },
 838
 839 );
 840
 841 =head2 Update  ARGSHASH
 842
 843 Updates fields on an object for you using the proper Set methods,
 844 skipping unchanged values.
 845
 846  ARGSRef => a hashref of attributes => value for the update
 847  AttributesRef => an arrayref of keys in ARGSRef that should be updated
 848  AttributePrefix => a prefix that should be added to the attributes in AttributesRef
 849                     when looking up values in ARGSRef
 850                     Bare attributes are tried before prefixed attributes
 851
 852 Returns a list of localized results of the update
 853
 854 =cut
 855
 856 sub Update {
 857     my $self = shift;
 858
 859     my %args = (
 860         ARGSRef         => undef,
 861         AttributesRef   => undef,
 862         AttributePrefix => undef,
 863         @_
 864     );
 865
 866     my $attributes = $args{'AttributesRef'};
 867     my $ARGSRef    = $args{'ARGSRef'};
 868     my %new_values;
 869
 870     # gather all new values
 871     foreach my $attribute (@$attributes) {
 872         my $value;
 873         if ( defined $ARGSRef->{$attribute} ) {
 874             $value = $ARGSRef->{$attribute};
 875         }
 876         elsif (
 877             defined( $args{'AttributePrefix'} )
 878             && defined(
 879                 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
 880             )
 881           ) {
 882             $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
 883
 884         }
 885         else {
 886             next;
 887         }
 888
 889         $value =~ s/\r\n/\n/gs;
 890
 891         # If Queue is 'General', we want to resolve the queue name for
 892         # the object.
 893
 894         # This is in an eval block because $object might not exist.
 895         # and might not have a Name method. But "can" won't find autoloaded
 896         # items. If it fails, we don't care
 897         do {
 898             no warnings "uninitialized";
 899             local $@;
 900             eval {
 901                 my $object = $attribute . "Obj";
 902                 my $name = $self->$object->Name;
 903                 next if $name eq $value || $name eq ($value || 0);
 904             };
 905             next if $value eq $self->$attribute();
 906             next if ($value || 0) eq $self->$attribute();
 907         };
 908
 909         $new_values{$attribute} = $value;
 910     }
 911
 912     return $self->_UpdateAttributes(
 913         Attributes => $attributes,
 914         NewValues  => \%new_values,
 915     );
 916 }
 917
 918 sub _UpdateAttributes {
 919     my $self = shift;
 920     my %args = (
 921         Attributes => [],
 922         NewValues  => {},
 923         @_,
 924     );
 925
 926     my @results;
 927
 928     foreach my $attribute (@{ $args{Attributes} }) {
 929         next if !exists($args{NewValues}{$attribute});
 930
 931         my $value = $args{NewValues}{$attribute};
 932         my $method = "Set$attribute";
 933         my ( $code, $msg ) = $self->$method($value);
 934         my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
 935
 936         # Default to $id, but use name if we can get it.
 937         my $label = $self->id;
 938         $label = $self->Name if (UNIVERSAL::can($self,'Name'));
 939         # this requires model names to be loc'ed.
 940
 941 =for loc
 942
 943     "Ticket" # loc
 944     "User" # loc
 945     "Group" # loc
 946     "Queue" # loc
 947
 948 =cut
 949
 950         push @results, $self->loc( $prefix ) . " $label: ". $msg;
 951
 952 =for loc
 953
 954                                    "[_1] could not be set to [_2].",       # loc
 955                                    "That is already the current value",    # loc
 956                                    "No value sent to _Set!",               # loc
 957                                    "Illegal value for [_1]",               # loc
 958                                    "The new value has been set.",          # loc
 959                                    "No column specified",                  # loc
 960                                    "Immutable field",                      # loc
 961                                    "Nonexistant field?",                   # loc
 962                                    "Invalid data",                         # loc
 963                                    "Couldn't find row",                    # loc
 964                                    "Missing a primary key?: [_1]",         # loc
 965                                    "Found Object",                         # loc
 966
 967 =cut
 968
 969     }
 970
 971     return @results;
 972 }
 973
 974
 975
 976
 977 =head2 Members
 978
 979   This returns an RT::Links object which references all the tickets
 980 which are 'MembersOf' this ticket
 981
 982 =cut
 983
 984 sub Members {
 985     my $self = shift;
 986     return ( $self->_Links( 'Target', 'MemberOf' ) );
 987 }
 988
 989
 990
 991 =head2 MemberOf
 992
 993   This returns an RT::Links object which references all the tickets that this
 994 ticket is a 'MemberOf'
 995
 996 =cut
 997
 998 sub MemberOf {
 999     my $self = shift;
1000     return ( $self->_Links( 'Base', 'MemberOf' ) );
1001 }
1002
1003
1004
1005 =head2 RefersTo
1006
1007   This returns an RT::Links object which shows all references for which this ticket is a base
1008
1009 =cut
1010
1011 sub RefersTo {
1012     my $self = shift;
1013     return ( $self->_Links( 'Base', 'RefersTo' ) );
1014 }
1015
1016
1017
1018 =head2 ReferredToBy
1019
1020 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1021
1022 =cut
1023
1024 sub ReferredToBy {
1025     my $self = shift;
1026     return ( $self->_Links( 'Target', 'RefersTo' ) );
1027 }
1028
1029
1030
1031 =head2 DependedOnBy
1032
1033   This returns an RT::Links object which references all the tickets that depend on this one
1034
1035 =cut
1036
1037 sub DependedOnBy {
1038     my $self = shift;
1039     return ( $self->_Links( 'Target', 'DependsOn' ) );
1040 }
1041
1042
1043
1044
1045 =head2 HasUnresolvedDependencies
1046
1047 Takes a paramhash of Type (default to '__any').  Returns the number of
1048 unresolved dependencies, if $self->UnresolvedDependencies returns an
1049 object with one or more members of that type.  Returns false
1050 otherwise.
1051
1052 =cut
1053
1054 sub HasUnresolvedDependencies {
1055     my $self = shift;
1056     my %args = (
1057         Type   => undef,
1058         @_
1059     );
1060
1061     my $deps = $self->UnresolvedDependencies;
1062
1063     if ($args{Type}) {
1064         $deps->Limit( FIELD => 'Type',
1065               OPERATOR => '=',
1066               VALUE => $args{Type});
1067     }
1068     else {
1069             $deps->IgnoreType;
1070     }
1071
1072     if ($deps->Count > 0) {
1073         return $deps->Count;
1074     }
1075     else {
1076         return (undef);
1077     }
1078 }
1079
1080
1081
1082 =head2 UnresolvedDependencies
1083
1084 Returns an RT::Tickets object of tickets which this ticket depends on
1085 and which have a status of new, open or stalled. (That list comes from
1086 RT::Queue->ActiveStatusArray
1087
1088 =cut
1089
1090
1091 sub UnresolvedDependencies {
1092     my $self = shift;
1093     my $deps = RT::Tickets->new($self->CurrentUser);
1094
1095     my @live_statuses = RT::Queue->ActiveStatusArray();
1096     foreach my $status (@live_statuses) {
1097         $deps->LimitStatus(VALUE => $status);
1098     }
1099     $deps->LimitDependedOnBy($self->Id);
1100
1101     return($deps);
1102
1103 }
1104
1105
1106
1107 =head2 AllDependedOnBy
1108
1109 Returns an array of RT::Ticket objects which (directly or indirectly)
1110 depends on this ticket; takes an optional 'Type' argument in the param
1111 hash, which will limit returned tickets to that type, as well as cause
1112 tickets with that type to serve as 'leaf' nodes that stops the recursive
1113 dependency search.
1114
1115 =cut
1116
1117 sub AllDependedOnBy {
1118     my $self = shift;
1119     return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1120                                      Direction => 'Target', @_ );
1121 }
1122
1123 =head2 AllDependsOn
1124
1125 Returns an array of RT::Ticket objects which this ticket (directly or
1126 indirectly) depends on; takes an optional 'Type' argument in the param
1127 hash, which will limit returned tickets to that type, as well as cause
1128 tickets with that type to serve as 'leaf' nodes that stops the
1129 recursive dependency search.
1130
1131 =cut
1132
1133 sub AllDependsOn {
1134     my $self = shift;
1135     return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1136                                      Direction => 'Base', @_ );
1137 }
1138
1139 sub _AllLinkedTickets {
1140     my $self = shift;
1141
1142     my %args = (
1143         LinkType  => undef,
1144         Direction => undef,
1145         Type   => undef,
1146         _found => {},
1147         _top   => 1,
1148         @_
1149     );
1150
1151     my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1152     while (my $link = $dep->Next()) {
1153         my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1154         next unless ($uri->IsLocal());
1155         my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1156         next if $args{_found}{$obj->Id};
1157
1158         if (!$args{Type}) {
1159             $args{_found}{$obj->Id} = $obj;
1160             $obj->_AllLinkedTickets( %args, _top => 0 );
1161         }
1162         elsif ($obj->Type and $obj->Type eq $args{Type}) {
1163             $args{_found}{$obj->Id} = $obj;
1164         }
1165         else {
1166             $obj->_AllLinkedTickets( %args, _top => 0 );
1167         }
1168     }
1169
1170     if ($args{_top}) {
1171         return map { $args{_found}{$_} } sort keys %{$args{_found}};
1172     }
1173     else {
1174         return 1;
1175     }
1176 }
1177
1178
1179
1180 =head2 DependsOn
1181
1182   This returns an RT::Links object which references all the tickets that this ticket depends on
1183
1184 =cut
1185
1186 sub DependsOn {
1187     my $self = shift;
1188     return ( $self->_Links( 'Base', 'DependsOn' ) );
1189 }
1190
1191 # }}}
1192
1193 # {{{ Customers
1194
1195 =head2 Customers
1196
1197   This returns an RT::Links object which references all the customers that
1198   this object is a member of.  This includes both explicitly linked customers
1199   and links implied by services.
1200
1201 =cut
1202
1203 sub Customers {
1204     my( $self, %opt ) = @_;
1205     my $Debug = $opt{'Debug'};
1206
1207     unless ( $self->{'Customers'} ) {
1208
1209       $self->{'Customers'} = $self->MemberOf->Clone;
1210
1211       for my $fstable (qw(cust_main cust_svc)) {
1212
1213         $self->{'Customers'}->Limit(
1214                                      FIELD    => 'Target',
1215                                      OPERATOR => 'STARTSWITH',
1216                                      VALUE    => "freeside://freeside/$fstable",
1217                                      ENTRYAGGREGATOR => 'OR',
1218                                      SUBCLAUSE => 'customers',
1219                                    );
1220       }
1221     }
1222
1223     warn "->Customers method called on $self; returning ".
1224          ref($self->{'Customers'}). ' object'
1225       if $Debug;
1226
1227     return $self->{'Customers'};
1228 }
1229
1230 # }}}
1231
1232 # {{{ Services
1233
1234 =head2 Services
1235
1236   This returns an RT::Links object which references all the services this
1237   object is a member of.
1238
1239 =cut
1240
1241 sub Services {
1242     my( $self, %opt ) = @_;
1243
1244     unless ( $self->{'Services'} ) {
1245
1246       $self->{'Services'} = $self->MemberOf->Clone;
1247
1248       $self->{'Services'}->Limit(
1249                                    FIELD    => 'Target',
1250                                    OPERATOR => 'STARTSWITH',
1251                                    VALUE    => "freeside://freeside/cust_svc",
1252                                  );
1253     }
1254
1255     return $self->{'Services'};
1256 }
1257
1258
1259
1260
1261
1262
1263 =head2 Links DIRECTION [TYPE]
1264
1265 Return links (L<RT::Links>) to/from this object.
1266
1267 DIRECTION is either 'Base' or 'Target'.
1268
1269 TYPE is a type of links to return, it can be omitted to get
1270 links of any type.
1271
1272 =cut
1273
1274 sub Links { shift->_Links(@_) }
1275
1276 sub _Links {
1277     my $self = shift;
1278
1279     #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1280     #tobias meant by $f
1281     my $field = shift;
1282     my $type  = shift || "";
1283
1284     unless ( $self->{"$field$type"} ) {
1285         $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1286             # at least to myself
1287             $self->{"$field$type"}->Limit( FIELD => $field,
1288                                            VALUE => $self->URI,
1289                                            ENTRYAGGREGATOR => 'OR' );
1290             $self->{"$field$type"}->Limit( FIELD => 'Type',
1291                                            VALUE => $type )
1292               if ($type);
1293     }
1294     return ( $self->{"$field$type"} );
1295 }
1296
1297
1298
1299
1300 =head2 FormatType
1301
1302 Takes a Type and returns a string that is more human readable.
1303
1304 =cut
1305
1306 sub FormatType{
1307     my $self = shift;
1308     my %args = ( Type => '',
1309                  @_
1310                );
1311     $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1312     $args{Type} =~ s/^\s+//;
1313     return $args{Type};
1314 }
1315
1316
1317
1318
1319 =head2 FormatLink
1320
1321 Takes either a Target or a Base and returns a string of human friendly text.
1322
1323 =cut
1324
1325 sub FormatLink {
1326     my $self = shift;
1327     my %args = ( Object => undef,
1328                  FallBack => '',
1329                  @_
1330                );
1331     my $text = "URI " . $args{FallBack};
1332     if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1333         $text = "Ticket " . $args{Object}->id;
1334     }
1335     return $text;
1336 }
1337
1338
1339
1340 =head2 _AddLink
1341
1342 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1343
1344 Returns C<link id>, C<message> and C<exist> flag.
1345
1346
1347 =cut
1348
1349 sub _AddLink {
1350     my $self = shift;
1351     my %args = ( Target => '',
1352                  Base   => '',
1353                  Type   => '',
1354                  Silent => undef,
1355                  @_ );
1356
1357
1358     # Remote_link is the URI of the object that is not this ticket
1359     my $remote_link;
1360     my $direction;
1361
1362     if ( $args{'Base'} and $args{'Target'} ) {
1363         $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1364         return ( 0, $self->loc("Can't specifiy both base and target") );
1365     }
1366     elsif ( $args{'Base'} ) {
1367         $args{'Target'} = $self->URI();
1368         $remote_link    = $args{'Base'};
1369         $direction      = 'Target';
1370     }
1371     elsif ( $args{'Target'} ) {
1372         $args{'Base'} = $self->URI();
1373         $remote_link  = $args{'Target'};
1374         $direction    = 'Base';
1375     }
1376     else {
1377         return ( 0, $self->loc('Either base or target must be specified') );
1378     }
1379
1380     # Check if the link already exists - we don't want duplicates
1381     use RT::Link;
1382     my $old_link = RT::Link->new( $self->CurrentUser );
1383     $old_link->LoadByParams( Base   => $args{'Base'},
1384                              Type   => $args{'Type'},
1385                              Target => $args{'Target'} );
1386     if ( $old_link->Id ) {
1387         $RT::Logger->debug("$self Somebody tried to duplicate a link");
1388         return ( $old_link->id, $self->loc("Link already exists"), 1 );
1389     }
1390
1391     # }}}
1392
1393
1394     # Storing the link in the DB.
1395     my $link = RT::Link->new( $self->CurrentUser );
1396     my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1397                                   Base   => $args{Base},
1398                                   Type   => $args{Type} );
1399
1400     unless ($linkid) {
1401         $RT::Logger->error("Link could not be created: ".$linkmsg);
1402         return ( 0, $self->loc("Link could not be created") );
1403     }
1404
1405     my $basetext = $self->FormatLink(Object => $link->BaseObj,
1406                                      FallBack => $args{Base});
1407     my $targettext = $self->FormatLink(Object => $link->TargetObj,
1408                                        FallBack => $args{Target});
1409     my $typetext = $self->FormatType(Type => $args{Type});
1410     my $TransString =
1411       "$basetext $typetext $targettext.";
1412     return ( $linkid, $TransString ) ;
1413 }
1414
1415
1416
1417 =head2 _DeleteLink
1418
1419 Delete a link. takes a paramhash of Base, Target and Type.
1420 Either Base or Target must be null. The null value will
1421 be replaced with this ticket\'s id
1422
1423 =cut
1424
1425 sub _DeleteLink {
1426     my $self = shift;
1427     my %args = (
1428         Base   => undef,
1429         Target => undef,
1430         Type   => undef,
1431         @_
1432     );
1433
1434     #we want one of base and target. we don't care which
1435     #but we only want _one_
1436
1437     my $direction;
1438     my $remote_link;
1439
1440     if ( $args{'Base'} and $args{'Target'} ) {
1441         $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1442         return ( 0, $self->loc("Can't specifiy both base and target") );
1443     }
1444     elsif ( $args{'Base'} ) {
1445         $args{'Target'} = $self->URI();
1446         $remote_link = $args{'Base'};
1447         $direction = 'Target';
1448     }
1449     elsif ( $args{'Target'} ) {
1450         $args{'Base'} = $self->URI();
1451         $remote_link = $args{'Target'};
1452         $direction='Base';
1453     }
1454     else {
1455         $RT::Logger->error("Base or Target must be specified");
1456         return ( 0, $self->loc('Either base or target must be specified') );
1457     }
1458
1459     my $link = RT::Link->new( $self->CurrentUser );
1460     $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} );
1461
1462
1463     $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=>  $args{'Target'} );
1464     #it's a real link.
1465
1466     if ( $link->id ) {
1467         my $basetext = $self->FormatLink(Object => $link->BaseObj,
1468                                      FallBack => $args{Base});
1469         my $targettext = $self->FormatLink(Object => $link->TargetObj,
1470                                        FallBack => $args{Target});
1471         my $typetext = $self->FormatType(Type => $args{Type});
1472         my $linkid = $link->id;
1473         $link->Delete();
1474         my $TransString = "$basetext no longer $typetext $targettext.";
1475         return ( 1, $TransString);
1476     }
1477
1478     #if it's not a link we can find
1479     else {
1480         $RT::Logger->debug("Couldn't find that link");
1481         return ( 0, $self->loc("Link not found") );
1482     }
1483 }
1484
1485
1486 =head1 LockForUpdate
1487
1488 In a database transaction, gains an exclusive lock on the row, to
1489 prevent race conditions.  On SQLite, this is a "RESERVED" lock on the
1490 entire database.
1491
1492 =cut
1493
1494 sub LockForUpdate {
1495     my $self = shift;
1496
1497     my $pk = $self->_PrimaryKey;
1498     my $id = @_ ? $_[0] : $self->$pk;
1499     $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1500     if (RT->Config->Get('DatabaseType') eq "SQLite") {
1501         # SQLite does DB-level locking, upgrading the transaction to
1502         # "RESERVED" on the first UPDATE/INSERT/DELETE.  Do a no-op
1503         # UPDATE to force the upgade.
1504         return RT->DatabaseHandle->dbh->do(
1505             "UPDATE " .$self->Table.
1506                 " SET $pk = $pk WHERE 1 = 0");
1507     } else {
1508         return $self->_LoadFromSQL(
1509             "SELECT * FROM ".$self->Table
1510                 ." WHERE $pk = ? FOR UPDATE",
1511             $id,
1512         );
1513     }
1514 }
1515
1516 =head2 _NewTransaction  PARAMHASH
1517
1518 Private function to create a new RT::Transaction object for this ticket update
1519
1520 =cut
1521
1522 sub _NewTransaction {
1523     my $self = shift;
1524     my %args = (
1525         TimeTaken => undef,
1526         Type      => undef,
1527         OldValue  => undef,
1528         NewValue  => undef,
1529         OldReference  => undef,
1530         NewReference  => undef,
1531         ReferenceType => undef,
1532         Data      => undef,
1533         Field     => undef,
1534         MIMEObj   => undef,
1535         ActivateScrips => 1,
1536         CommitScrips => 1,
1537         SquelchMailTo => undef,
1538         CustomFields => {},
1539         @_
1540     );
1541
1542     my $in_txn = RT->DatabaseHandle->TransactionDepth;
1543     RT->DatabaseHandle->BeginTransaction unless $in_txn;
1544
1545     $self->LockForUpdate;
1546
1547     my $old_ref = $args{'OldReference'};
1548     my $new_ref = $args{'NewReference'};
1549     my $ref_type = $args{'ReferenceType'};
1550     if ($old_ref or $new_ref) {
1551         $ref_type ||= ref($old_ref) || ref($new_ref);
1552         if (!$ref_type) {
1553             $RT::Logger->error("Reference type not specified for transaction");
1554             return;
1555         }
1556         $old_ref = $old_ref->Id if ref($old_ref);
1557         $new_ref = $new_ref->Id if ref($new_ref);
1558     }
1559
1560     require RT::Transaction;
1561     my $trans = RT::Transaction->new( $self->CurrentUser );
1562     my ( $transaction, $msg ) = $trans->Create(
1563         ObjectId  => $self->Id,
1564         ObjectType => ref($self),
1565         TimeTaken => $args{'TimeTaken'},
1566         Type      => $args{'Type'},
1567         Data      => $args{'Data'},
1568         Field     => $args{'Field'},
1569         NewValue  => $args{'NewValue'},
1570         OldValue  => $args{'OldValue'},
1571         NewReference  => $new_ref,
1572         OldReference  => $old_ref,
1573         ReferenceType => $ref_type,
1574         MIMEObj   => $args{'MIMEObj'},
1575         ActivateScrips => $args{'ActivateScrips'},
1576         CommitScrips => $args{'CommitScrips'},
1577         SquelchMailTo => $args{'SquelchMailTo'},
1578         CustomFields => $args{'CustomFields'},
1579     );
1580
1581     # Rationalize the object since we may have done things to it during the caching.
1582     $self->Load($self->Id);
1583
1584     $RT::Logger->warning($msg) unless $transaction;
1585
1586     $self->_SetLastUpdated;
1587
1588     if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1589         $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1590     }
1591     if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1592             push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1593     }
1594
1595     RT->DatabaseHandle->Commit unless $in_txn;
1596
1597     return ( $transaction, $msg, $trans );
1598 }
1599
1600
1601
1602 =head2 Transactions
1603
1604   Returns an RT::Transactions object of all transactions on this record object
1605
1606 =cut
1607
1608 sub Transactions {
1609     my $self = shift;
1610
1611     use RT::Transactions;
1612     my $transactions = RT::Transactions->new( $self->CurrentUser );
1613
1614     #If the user has no rights, return an empty object
1615     $transactions->Limit(
1616         FIELD => 'ObjectId',
1617         VALUE => $self->id,
1618     );
1619     $transactions->Limit(
1620         FIELD => 'ObjectType',
1621         VALUE => ref($self),
1622     );
1623
1624     return ($transactions);
1625 }
1626
1627 #
1628
1629 sub CustomFields {
1630     my $self = shift;
1631     my $cfs  = RT::CustomFields->new( $self->CurrentUser );
1632
1633     $cfs->SetContextObject( $self );
1634     # XXX handle multiple types properly
1635     $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1636     $cfs->LimitToGlobalOrObjectId(
1637         $self->_LookupId( $self->CustomFieldLookupType )
1638     );
1639     $cfs->ApplySortOrder;
1640
1641     return $cfs;
1642 }
1643
1644 # TODO: This _only_ works for RT::Class classes. it doesn't work, for example,
1645 # for RT::IR classes.
1646
1647 sub _LookupId {
1648     my $self = shift;
1649     my $lookup = shift;
1650     my @classes = ($lookup =~ /RT::(\w+)-/g);
1651
1652     my $object = $self;
1653     foreach my $class (reverse @classes) {
1654         my $method = "${class}Obj";
1655         $object = $object->$method;
1656     }
1657
1658     return $object->Id;
1659 }
1660
1661
1662 =head2 CustomFieldLookupType
1663
1664 Returns the path RT uses to figure out which custom fields apply to this object.
1665
1666 =cut
1667
1668 sub CustomFieldLookupType {
1669     my $self = shift;
1670     return ref($self);
1671 }
1672
1673
1674 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1675
1676 VALUE should be a string. FIELD can be any identifier of a CustomField
1677 supported by L</LoadCustomFieldByIdentifier> method.
1678
1679 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
1680 deletes the old value.
1681 If VALUE is not a valid value for the custom field, returns
1682 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
1683 $id is ID of created L<ObjectCustomFieldValue> object.
1684
1685 =cut
1686
1687 sub AddCustomFieldValue {
1688     my $self = shift;
1689     $self->_AddCustomFieldValue(@_);
1690 }
1691
1692 sub _AddCustomFieldValue {
1693     my $self = shift;
1694     my %args = (
1695         Field             => undef,
1696         Value             => undef,
1697         LargeContent      => undef,
1698         ContentType       => undef,
1699         RecordTransaction => 1,
1700         @_
1701     );
1702
1703     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1704     unless ( $cf->Id ) {
1705         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1706     }
1707
1708     my $OCFs = $self->CustomFields;
1709     $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1710     unless ( $OCFs->Count ) {
1711         return (
1712             0,
1713             $self->loc(
1714                 "Custom field [_1] does not apply to this object",
1715                 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
1716             )
1717         );
1718     }
1719
1720     # empty string is not correct value of any CF, so undef it
1721     foreach ( qw(Value LargeContent) ) {
1722         $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
1723     }
1724
1725     unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1726         return ( 0, $self->loc("Invalid value for custom field") );
1727     }
1728
1729     # If the custom field only accepts a certain # of values, delete the existing
1730     # value and record a "changed from foo to bar" transaction
1731     unless ( $cf->UnlimitedValues ) {
1732
1733         # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1734         my $values = $cf->ValuesForObject($self);
1735
1736         # We need to whack any old values here.  In most cases, the custom field should
1737         # only have one value to delete.  In the pathalogical case, this custom field
1738         # used to be a multiple and we have many values to whack....
1739         my $cf_values = $values->Count;
1740
1741         if ( $cf_values > $cf->MaxValues ) {
1742             my $i = 0;   #We want to delete all but the max we can currently have , so we can then
1743                  # execute the same code to "change" the value from old to new
1744             while ( my $value = $values->Next ) {
1745                 $i++;
1746                 if ( $i < $cf_values ) {
1747                     my ( $val, $msg ) = $cf->DeleteValueForObject(
1748                         Object  => $self,
1749                         Content => $value->Content
1750                     );
1751                     unless ($val) {
1752                         return ( 0, $msg );
1753                     }
1754                     my ( $TransactionId, $Msg, $TransactionObj ) =
1755                       $self->_NewTransaction(
1756                         Type         => 'CustomField',
1757                         Field        => $cf->Id,
1758                         OldReference => $value,
1759                       );
1760                 }
1761             }
1762             $values->RedoSearch if $i; # redo search if have deleted at least one value
1763         }
1764
1765         my ( $old_value, $old_content );
1766         if ( $old_value = $values->First ) {
1767             $old_content = $old_value->Content;
1768             $old_content = undef if defined $old_content && !length $old_content;
1769
1770             my $is_the_same = 1;
1771             if ( defined $args{'Value'} ) {
1772                 $is_the_same = 0 unless defined $old_content
1773                     && lc $old_content eq lc $args{'Value'};
1774             } else {
1775                 $is_the_same = 0 if defined $old_content;
1776             }
1777             if ( $is_the_same ) {
1778                 my $old_content = $old_value->LargeContent;
1779                 if ( defined $args{'LargeContent'} ) {
1780                     $is_the_same = 0 unless defined $old_content
1781                         && $old_content eq $args{'LargeContent'};
1782                 } else {
1783                     $is_the_same = 0 if defined $old_content;
1784                 }
1785             }
1786
1787             return $old_value->id if $is_the_same;
1788         }
1789
1790         my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1791             Object       => $self,
1792             Content      => $args{'Value'},
1793             LargeContent => $args{'LargeContent'},
1794             ContentType  => $args{'ContentType'},
1795         );
1796
1797         unless ( $new_value_id ) {
1798             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
1799         }
1800
1801         my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1802         $new_value->Load( $new_value_id );
1803
1804         # now that adding the new value was successful, delete the old one
1805         if ( $old_value ) {
1806             my ( $val, $msg ) = $old_value->Delete();
1807             return ( 0, $msg ) unless $val;
1808         }
1809
1810         if ( $args{'RecordTransaction'} ) {
1811             my ( $TransactionId, $Msg, $TransactionObj ) =
1812               $self->_NewTransaction(
1813                 Type         => 'CustomField',
1814                 Field        => $cf->Id,
1815                 OldReference => $old_value,
1816                 NewReference => $new_value,
1817               );
1818         }
1819
1820         my $new_content = $new_value->Content;
1821
1822         # For datetime, we need to display them in "human" format in result message
1823         #XXX TODO how about date without time?
1824         if ($cf->Type eq 'DateTime') {
1825             my $DateObj = RT::Date->new( $self->CurrentUser );
1826             $DateObj->Set(
1827                 Format => 'ISO',
1828                 Value  => $new_content,
1829             );
1830             $new_content = $DateObj->AsString;
1831
1832             if ( defined $old_content && length $old_content ) {
1833                 $DateObj->Set(
1834                     Format => 'ISO',
1835                     Value  => $old_content,
1836                 );
1837                 $old_content = $DateObj->AsString;
1838             }
1839         }
1840
1841         unless ( defined $old_content && length $old_content ) {
1842             return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
1843         }
1844         elsif ( !defined $new_content || !length $new_content ) {
1845             return ( $new_value_id,
1846                 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
1847         }
1848         else {
1849             return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
1850         }
1851
1852     }
1853
1854     # otherwise, just add a new value and record "new value added"
1855     else {
1856         my ($new_value_id, $msg) = $cf->AddValueForObject(
1857             Object       => $self,
1858             Content      => $args{'Value'},
1859             LargeContent => $args{'LargeContent'},
1860             ContentType  => $args{'ContentType'},
1861         );
1862
1863         unless ( $new_value_id ) {
1864             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
1865         }
1866         if ( $args{'RecordTransaction'} ) {
1867             my ( $tid, $msg ) = $self->_NewTransaction(
1868                 Type          => 'CustomField',
1869                 Field         => $cf->Id,
1870                 NewReference  => $new_value_id,
1871                 ReferenceType => 'RT::ObjectCustomFieldValue',
1872             );
1873             unless ( $tid ) {
1874                 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
1875             }
1876         }
1877         return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
1878     }
1879 }
1880
1881
1882
1883 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1884
1885 Deletes VALUE as a value of CustomField FIELD.
1886
1887 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1888
1889 If VALUE is not a valid value for the custom field, returns
1890 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1891
1892 =cut
1893
1894 sub DeleteCustomFieldValue {
1895     my $self = shift;
1896     my %args = (
1897         Field   => undef,
1898         Value   => undef,
1899         ValueId => undef,
1900         @_
1901     );
1902
1903     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1904     unless ( $cf->Id ) {
1905         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1906     }
1907
1908     my ( $val, $msg ) = $cf->DeleteValueForObject(
1909         Object  => $self,
1910         Id      => $args{'ValueId'},
1911         Content => $args{'Value'},
1912     );
1913     unless ($val) {
1914         return ( 0, $msg );
1915     }
1916
1917     my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1918         Type          => 'CustomField',
1919         Field         => $cf->Id,
1920         OldReference  => $val,
1921         ReferenceType => 'RT::ObjectCustomFieldValue',
1922     );
1923     unless ($TransactionId) {
1924         return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1925     }
1926
1927     my $old_value = $TransactionObj->OldValue;
1928     # For datetime, we need to display them in "human" format in result message
1929     if ( $cf->Type eq 'DateTime' ) {
1930         my $DateObj = RT::Date->new( $self->CurrentUser );
1931         $DateObj->Set(
1932             Format => 'ISO',
1933             Value  => $old_value,
1934         );
1935         $old_value = $DateObj->AsString;
1936     }
1937     return (
1938         $TransactionId,
1939         $self->loc(
1940             "[_1] is no longer a value for custom field [_2]",
1941             $old_value, $cf->Name
1942         )
1943     );
1944 }
1945
1946
1947
1948 =head2 FirstCustomFieldValue FIELD
1949
1950 Return the content of the first value of CustomField FIELD for this ticket
1951 Takes a field id or name
1952
1953 =cut
1954
1955 sub FirstCustomFieldValue {
1956     my $self = shift;
1957     my $field = shift;
1958
1959     my $values = $self->CustomFieldValues( $field );
1960     return undef unless my $first = $values->First;
1961     return $first->Content;
1962 }
1963
1964 =head2 CustomFieldValuesAsString FIELD
1965
1966 Return the content of the CustomField FIELD for this ticket.
1967 If this is a multi-value custom field, values will be joined with newlines.
1968
1969 Takes a field id or name as the first argument
1970
1971 Takes an optional Separator => "," second and third argument
1972 if you want to join the values using something other than a newline
1973
1974 =cut
1975
1976 sub CustomFieldValuesAsString {
1977     my $self  = shift;
1978     my $field = shift;
1979     my %args  = @_;
1980     my $separator = $args{Separator} || "\n";
1981
1982     my $values = $self->CustomFieldValues( $field );
1983     return join ($separator, grep { defined $_ }
1984                  map { $_->Content } @{$values->ItemsArrayRef});
1985 }
1986
1987
1988
1989 =head2 CustomFieldValues FIELD
1990
1991 Return a ObjectCustomFieldValues object of all values of the CustomField whose
1992 id or Name is FIELD for this record.
1993
1994 Returns an RT::ObjectCustomFieldValues object
1995
1996 =cut
1997
1998 sub CustomFieldValues {
1999     my $self  = shift;
2000     my $field = shift;
2001
2002     if ( $field ) {
2003         my $cf = $self->LoadCustomFieldByIdentifier( $field );
2004
2005         # we were asked to search on a custom field we couldn't find
2006         unless ( $cf->id ) {
2007             $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2008             return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2009         }
2010         return ( $cf->ValuesForObject($self) );
2011     }
2012
2013     # we're not limiting to a specific custom field;
2014     my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2015     $ocfs->LimitToObject( $self );
2016     return $ocfs;
2017 }
2018
2019 =head2 LoadCustomFieldByIdentifier IDENTIFER
2020
2021 Find the custom field has id or name IDENTIFIER for this object.
2022
2023 If no valid field is found, returns an empty RT::CustomField object.
2024
2025 =cut
2026
2027 sub LoadCustomFieldByIdentifier {
2028     my $self = shift;
2029     my $field = shift;
2030
2031     my $cf;
2032     if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2033         $cf = RT::CustomField->new($self->CurrentUser);
2034         $cf->SetContextObject( $self );
2035         $cf->LoadById( $field->id );
2036     }
2037     elsif ($field =~ /^\d+$/) {
2038         $cf = RT::CustomField->new($self->CurrentUser);
2039         $cf->SetContextObject( $self );
2040         $cf->LoadById($field);
2041     } else {
2042
2043         my $cfs = $self->CustomFields($self->CurrentUser);
2044         $cfs->SetContextObject( $self );
2045         $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2046         $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2047     }
2048     return $cf;
2049 }
2050
2051 sub ACLEquivalenceObjects { }
2052
2053 sub BasicColumns { }
2054
2055 sub WikiBase {
2056     return RT->Config->Get('WebPath'). "/index.html?q=";
2057 }
2058
2059 RT::Base->_ImportOverlays();
2060
2061 1;