rt/lib/RT/Record.pm

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