rt/lib/RT/Record.pm

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