rt/lib/RT/Record.pm

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