Record.pm 70.1 KB
Newer Older
1
# BEGIN BPS TAGGED BLOCK {{{
Jesse Vincent's avatar
Jesse Vincent committed
2
#
3
# COPYRIGHT:
Jesse Vincent's avatar
Jesse Vincent committed
4
#
5
# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
Kevin Falcone's avatar
Kevin Falcone committed
6
#                                          <sales@bestpractical.com>
Jesse Vincent's avatar
Jesse Vincent committed
7
#
8
# (Except where explicitly superseded by other copyright notices)
Jesse Vincent's avatar
Jesse Vincent committed
9
10
#
#
11
# LICENSE:
Jesse Vincent's avatar
Jesse Vincent committed
12
#
13
14
15
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# been provided with this software, but in any event can be snarfed
16
# from www.gnu.org.
Jesse Vincent's avatar
Jesse Vincent committed
17
#
18
19
20
21
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
Jesse Vincent's avatar
Jesse Vincent committed
22
#
23
24
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
Jesse Vincent's avatar
Jesse Vincent committed
25
26
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301 or visit their web page on the internet at
Ruslan Zakirov's avatar
Ruslan Zakirov committed
27
# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
Jesse Vincent's avatar
Jesse Vincent committed
28
29
#
#
30
# CONTRIBUTION SUBMISSION POLICY:
Jesse Vincent's avatar
Jesse Vincent committed
31
#
32
33
34
35
36
# (The following paragraph is not intended to limit the rights granted
# to you to modify and distribute this software under the terms of
# the GNU General Public License and is only of importance to you if
# you choose to contribute your changes and enhancements to the
# community by submitting them to Best Practical Solutions, LLC.)
Jesse Vincent's avatar
Jesse Vincent committed
37
#
38
39
40
41
42
43
44
45
# By intentionally submitting any modifications, corrections or
# derivatives to this work, or any other work intended for use with
# Request Tracker, to Best Practical Solutions, LLC, you confirm that
# you are the copyright holder for those contributions and you grant
# Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
# royalty-free, perpetual, license to use, copy, create derivative
# works based on those contributions, and sublicense and distribute
# those contributions and any derivatives thereof.
Jesse Vincent's avatar
Jesse Vincent committed
46
#
47
# END BPS TAGGED BLOCK }}}
48

Jesse Vincent's avatar
Jesse Vincent committed
49
50
51
52
53
54
55
56
57
58
=head1 NAME

  RT::Record - Base class for RT record objects

=head1 SYNOPSIS


=head1 DESCRIPTION


Jesse Vincent's avatar
Jesse Vincent committed
59

Jesse Vincent's avatar
Jesse Vincent committed
60
61
62
63
=head1 METHODS

=cut

Jesse Vincent's avatar
Jesse Vincent committed
64
package RT::Record;
65
66
67
68

use strict;
use warnings;

69
70
71
use RT;
use base RT->Config->Get('RecordBaseClass');
use base 'RT::Base';
72

73
74
75
76
77
require RT::Date;
require RT::User;
require RT::Attributes;
require RT::Transactions;
require RT::Link;
78
use Encode qw();
79

80
our $_TABLE_ATTR = { };
81

Jesse Vincent's avatar
Jesse Vincent committed
82

83
84
sub _Init {
    my $self = shift;
85
    $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
Jesse Vincent's avatar
Jesse Vincent committed
86
    $self->CurrentUser(@_);
Jesse Vincent's avatar
Jesse Vincent committed
87
88
89
}


90
91
92
93
94
95
96

=head2 _PrimaryKeys

The primary keys for RT classes is 'id'

=cut

Ruslan Zakirov's avatar
Ruslan Zakirov committed
97
sub _PrimaryKeys { return ['id'] }
98
99
100
101
102
103
104
105
106
107
108
109
110
# short circuit many, many thousands of calls from searchbuilder
sub _PrimaryKey { 'id' }

=head2 Id

Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do
on a very common codepath

C<id> is an alias to C<Id> and is the preferred way to call this method.

=cut

sub Id {
111
    return shift->{'values'}->{id};
112
}
113

114
*id = \&Id;
115

116
117
118
119
120
121
122
123
=head2 Delete

Delete this record object from the database.

=cut

sub Delete {
    my $self = shift;
124
125
126
127
128
129
130
    my ($rv) = $self->SUPER::Delete;
    if ($rv) {
        return ($rv, $self->loc("Object deleted"));
    } else {

        return(0, $self->loc("Object could not be deleted"))
    } 
131
132
}

133
=head2 RecordType
134

135
136
Returns a string which is this record's type. It's not localized and by
default last part (everything after last ::) of class name is returned.
137

138
=cut
139

140
141
142
143
144
sub RecordType {
    my $res = ref($_[0]) || $_[0];
    $res =~ s/.*:://;
    return $res;
}
145

146
=head2 ObjectTypeStr
147

148
DEPRECATED. Stays here for backwards. Returns localized L</RecordType>.
149
150
151

=cut

152
153
154
155
156
157
158
# we deprecate because of:
# * ObjectType is used in several classes with ObjectId to store
#   records of different types, for example transactions use those
#   and it's unclear what this method should return 'Transaction'
#   or type of referenced record
# * returning localized thing is not good idea

159
160
sub ObjectTypeStr {
    my $self = shift;
161
162
163
164
    RT->Deprecated(
        Remove => "4.4",
        Instead => "RecordType",
    );
165
    return $self->loc( $self->RecordType( @_ ) );
166
167
}

Jesse Vincent's avatar
Jesse Vincent committed
168
169
170
171
172
173
174
175
176
=head2 Attributes

Return this object's attributes as an RT::Attributes object

=cut

sub Attributes {
    my $self = shift;
    unless ($self->{'attributes'}) {
177
178
179
        $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
        $self->{'attributes'}->LimitToObject($self);
        $self->{'attributes'}->OrderByCols({FIELD => 'id'});
Jesse Vincent's avatar
Jesse Vincent committed
180
    }
181
    return ($self->{'attributes'});
Jesse Vincent's avatar
Jesse Vincent committed
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
}


=head2 AddAttribute { Name, Description, Content }

Adds a new attribute for this object.

=cut

sub AddAttribute {
    my $self = shift;
    my %args = ( Name        => undef,
                 Description => undef,
                 Content     => undef,
                 @_ );

    my $attr = RT::Attribute->new( $self->CurrentUser );
199
200
    my ( $id, $msg ) = $attr->Create( 
                                      Object    => $self,
Jesse Vincent's avatar
Jesse Vincent committed
201
202
203
204
                                      Name        => $args{'Name'},
                                      Description => $args{'Description'},
                                      Content     => $args{'Content'} );

Ruslan Zakirov's avatar
Ruslan Zakirov committed
205

206
207
    # XXX TODO: Why won't RedoSearch work here?                                     
    $self->Attributes->_DoSearch;
Jesse Vincent's avatar
Jesse Vincent committed
208
209
210
211
212
    
    return ($id, $msg);
}


213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
=head2 SetAttribute { Name, Description, Content }

Like AddAttribute, but replaces all existing attributes with the same Name.

=cut

sub SetAttribute {
    my $self = shift;
    my %args = ( Name        => undef,
                 Description => undef,
                 Content     => undef,
                 @_ );

    my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
        or return $self->AddAttribute( %args );

    my $AttributeObj = pop( @AttributeObjs );
    $_->Delete foreach @AttributeObjs;

    $AttributeObj->SetDescription( $args{'Description'} );
    $AttributeObj->SetContent( $args{'Content'} );

    $self->Attributes->RedoSearch;
    return 1;
}

=head2 DeleteAttribute NAME

Deletes all attributes with the matching name for this object.

=cut

sub DeleteAttribute {
    my $self = shift;
    my $name = shift;
248
249
250
    my ($val,$msg) =  $self->Attributes->DeleteEntry( Name => $name );
    $self->ClearAttributes;
    return ($val,$msg);
251
252
253
254
}

=head2 FirstAttribute NAME

255
256
Returns the first attribute with the matching name for this object (as an
L<RT::Attribute> object), or C<undef> if no such attributes exist.
257
258
If there is more than one attribute with the matching name on the
object, the first value that was set is returned.
259
260
261
262
263
264
265
266
267
268

=cut

sub FirstAttribute {
    my $self = shift;
    my $name = shift;
    return ($self->Attributes->Named( $name ))[0];
}


269
270
271
272
273
274
sub ClearAttributes {
    my $self = shift;
    delete $self->{'attributes'};

}

Ruslan Zakirov's avatar
Ruslan Zakirov committed
275
sub _Handle { return $RT::Handle }
276

Jesse Vincent's avatar
Jesse Vincent committed
277

Jesse Vincent's avatar
Jesse Vincent committed
278

Jesse Vincent's avatar
Jesse Vincent committed
279
=head2  Create PARAMHASH
280
281
282
283
284
285
286
287
288

Takes a PARAMHASH of Column -> Value pairs.
If any Column has a Validate$PARAMNAME subroutine defined and the 
value provided doesn't pass validation, this routine returns
an error.

If this object's table has any of the following atetributes defined as
'Auto', this routine will automatically fill in their values.

289
290
291
292
293
294
295
296
297
298
299
300
=over

=item Created

=item Creator

=item LastUpdated

=item LastUpdatedBy

=back

301
302
303
304
305
306
=cut

sub Create {
    my $self    = shift;
    my %attribs = (@_);
    foreach my $key ( keys %attribs ) {
307
308
        if (my $method = $self->can("Validate$key")) {
        if (! $method->( $self, $attribs{$key} ) ) {
309
            if (wantarray) {
310
                return ( 0, $self->loc('Invalid value for [_1]', $key) );
311
312
313
314
315
            }
            else {
                return (0);
            }
        }
316
        }
317
    }
318
319
320
321
322
323
324
325
326



    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime();

    my $now_iso =
     sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec);

    $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
327

Jesse Vincent's avatar
Jesse Vincent committed
328
329
330
    if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
         $attribs{'Creator'} = $self->CurrentUser->id || '0'; 
    }
331
    $attribs{'LastUpdated'} = $now_iso
Jesse Vincent's avatar
Jesse Vincent committed
332
      if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
333

Jesse Vincent's avatar
Jesse Vincent committed
334
    $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
Jesse Vincent's avatar
Jesse Vincent committed
335
      if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
336
337

    my $id = $self->SUPER::Create(%attribs);
Jesse Vincent's avatar
Jesse Vincent committed
338
339
340
341
342
343
344
345
346
347
348
    if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
        if ( $id->errno ) {
            if (wantarray) {
                return ( 0,
                    $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
            }
            else {
                return (0);
            }
        }
    }
349
350
351
352
    # If the object was created in the database, 
    # load it up now, so we're sure we get what the database 
    # has.  Arguably, this should not be necessary, but there
    # isn't much we can do about it.
Jesse Vincent's avatar
Jesse Vincent committed
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367

   unless ($id) { 
    if (wantarray) {
        return ( $id, $self->loc('Object could not be created') );
    }
    else {
        return ($id);
    }

   }

    if  (UNIVERSAL::isa('errno',$id)) {
        return(undef);
    }

368
369
    $self->Load($id) if ($id);

Jesse Vincent's avatar
Jesse Vincent committed
370
371


372
    if (wantarray) {
Jesse Vincent's avatar
Jesse Vincent committed
373
        return ( $id, $self->loc('Object created') );
374
375
376
377
378
    }
    else {
        return ($id);
    }

Jesse Vincent's avatar
Jesse Vincent committed
379
}
Jesse Vincent's avatar
Jesse Vincent committed
380

Jesse Vincent's avatar
Jesse Vincent committed
381

382

Jesse Vincent's avatar
Jesse Vincent committed
383
=head2 LoadByCols
384

Jesse Vincent's avatar
Jesse Vincent committed
385
Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the 
386
387
388
389
390
391
392
DB is case sensitive

=cut

sub LoadByCols {
    my $self = shift;

Jesse Vincent's avatar
Jesse Vincent committed
393
    # We don't want to hang onto this
394
    $self->ClearAttributes;
Jesse Vincent's avatar
Jesse Vincent committed
395

396
397
398
399
    unless ( $self->_Handle->CaseSensitive ) {
        my ( $ret, $msg ) = $self->SUPER::LoadByCols( @_ );
        return wantarray ? ( $ret, $msg ) : $ret;
    }
Ruslan Zakirov's avatar
Ruslan Zakirov committed
400

401
402
    # If this database is case sensitive we need to uncase objects for
    # explicit loading
Ruslan Zakirov's avatar
Ruslan Zakirov committed
403
404
405
406
407
408
409
410
411
412
413
414
    my %hash = (@_);
    foreach my $key ( keys %hash ) {

        # If we've been passed an empty value, we can't do the lookup. 
        # We don't need to explicitly downcase integers or an id.
        if ( $key ne 'id' && defined $hash{ $key } && $hash{ $key } !~ /^\d+$/ ) {
            my ($op, $val, $func);
            ($key, $op, $val, $func) =
                $self->_Handle->_MakeClauseCaseInsensitive( $key, '=', delete $hash{ $key } );
            $hash{$key}->{operator} = $op;
            $hash{$key}->{value}    = $val;
            $hash{$key}->{function} = $func;
415
        }
416
    }
417
418
    my ( $ret, $msg ) = $self->SUPER::LoadByCols( %hash );
    return wantarray ? ( $ret, $msg ) : $ret;
419
420
421
}


422
423
424
425
426

# There is room for optimizations in most of those subs:


sub LastUpdatedObj {
427
    my $self = shift;
428
    my $obj  = RT::Date->new( $self->CurrentUser );
429
430

    $obj->Set( Format => 'sql', Value => $self->LastUpdated );
431
432
433
434
435
436
    return $obj;
}



sub CreatedObj {
437
    my $self = shift;
438
    my $obj  = RT::Date->new( $self->CurrentUser );
439
440

    $obj->Set( Format => 'sql', Value => $self->Created );
441
442
443
444
445

    return $obj;
}


446
# B<DEPRECATED> and will be removed in 4.4
447
sub AgeAsString {
448
    my $self = shift;
449
450
451
452
    RT->Deprecated(
        Remove => "4.4",
        Instead => "->CreatedObj->AgeAsString",
    );
453
    return ( $self->CreatedObj->AgeAsString() );
454
}
455

456
457
458
# B<DEPRECATED> and will be removed in 4.4
sub LongSinceUpdateAsString {
    my $self = shift;
459
460
461
462
    RT->Deprecated(
        Remove => "4.4",
        Instead => "->LastUpdatedObj->AgeAsString",
    );
463
464
465
466
467
468
    if ( $self->LastUpdated ) {
        return ( $self->LastUpdatedObj->AgeAsString() );
    } else {
        return "never";
    }
}
469

470
sub LastUpdatedAsString {
471
472
473
    my $self = shift;
    if ( $self->LastUpdated ) {
        return ( $self->LastUpdatedObj->AsString() );
474
    } else {
475
        return "never";
476
477
478
479
480
    }
}

sub CreatedAsString {
    my $self = shift;
481
    return ( $self->CreatedObj->AsString() );
482
}
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

sub _Set {
    my $self = shift;

    my %args = (
        Field => undef,
        Value => undef,
        IsSQL => undef,
        @_
    );

    #if the user is trying to modify the record
    # TODO: document _why_ this code is here

    if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
        $args{'Value'} = 0;
    }

501
502
503
    my $old_val = $self->__Value($args{'Field'});
     $self->_SetLastUpdated();
    my $ret = $self->SUPER::_Set(
504
505
506
507
        Field => $args{'Field'},
        Value => $args{'Value'},
        IsSQL => $args{'IsSQL'}
    );
508
509
510
511
        my ($status, $msg) =  $ret->as_array();

        # @values has two values, a status code and a message.

512
513
    # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
    # we want to change the standard "success" message
514
    if ($status) {
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
        if ($self->SQLType( $args{'Field'}) =~ /text/) {
            $msg = $self->loc(
                "[_1] updated",
                $self->loc( $args{'Field'} ),
            );
        } else {
            $msg = $self->loc(
                "[_1] changed from [_2] to [_3]",
                $self->loc( $args{'Field'} ),
                ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ),
                '"' . $self->__Value( $args{'Field'}) . '"',
            );
        }
    } else {
        $msg = $self->CurrentUser->loc_fuzzy($msg);
530
531
    }

532
    return wantarray ? ($status, $msg) : $ret;
Jesse Vincent's avatar
Jesse Vincent committed
533
}
534

Jesse Vincent's avatar
Jesse Vincent committed
535
536
537


=head2 _SetLastUpdated
538

Jesse Vincent's avatar
Jesse Vincent committed
539
540
541
542
543
544
This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
It takes no options. Arguably, this is a bug

=cut

sub _SetLastUpdated {
Jesse Vincent's avatar
Jesse Vincent committed
545
    my $self = shift;
546
    my $now = RT::Date->new( $self->CurrentUser );
Jesse Vincent's avatar
Jesse Vincent committed
547
548
    $now->SetToNow();

549
550
551
552
553
    if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
        my ( $msg, $val ) = $self->__Set(
            Field => 'LastUpdated',
            Value => $now->ISO
        );
Jesse Vincent's avatar
Jesse Vincent committed
554
    }
555
556
557
558
559
    if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
        my ( $msg, $val ) = $self->__Set(
            Field => 'LastUpdatedBy',
            Value => $self->CurrentUser->id
        );
Jesse Vincent's avatar
Jesse Vincent committed
560
    }
Jesse Vincent's avatar
Jesse Vincent committed
561
562
}

Jesse Vincent's avatar
Jesse Vincent committed
563

564
565

=head2 CreatorObj
Jesse Vincent's avatar
Jesse Vincent committed
566
567

Returns an RT::User object with the RT account of the creator of this row
Jesse Vincent's avatar
Jesse Vincent committed
568

Jesse Vincent's avatar
Jesse Vincent committed
569
=cut
Jesse Vincent's avatar
Jesse Vincent committed
570

571
572
573
574
575
576
577
578
sub CreatorObj {
    my $self = shift;
    unless ( exists $self->{'CreatorObj'} ) {

        $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
        $self->{'CreatorObj'}->Load( $self->Creator );
    }
    return ( $self->{'CreatorObj'} );
579
}
580

581
582
583
584
585
586
587
588
589


=head2 LastUpdatedByObj

  Returns an RT::User object of the last user to touch this object

=cut

sub LastUpdatedByObj {
590
591
592
593
    my $self = shift;
    unless ( exists $self->{LastUpdatedByObj} ) {
        $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
        $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
594
595
    }
    return $self->{'LastUpdatedByObj'};
Jesse Vincent's avatar
   
Jesse Vincent committed
596
}
597

Jesse Vincent's avatar
   
Jesse Vincent committed
598

599
600
601
602
603
604
605
606
607
608
609
610
611
612

=head2 URI

Returns this record's URI

=cut

sub URI {
    my $self = shift;
    my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
    return($uri->URIForObject($self));
}


Jesse Vincent's avatar
Jesse Vincent committed
613
614
615
616
617
618
619
620
621
=head2 ValidateName NAME

Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name

=cut

sub ValidateName {
    my $self = shift;
    my $value = shift;
622
    if (defined $value && $value=~ /^\d+$/) {
Jesse Vincent's avatar
Jesse Vincent committed
623
624
        return(0);
    } else  {
625
        return(1);
Jesse Vincent's avatar
Jesse Vincent committed
626
627
    }
}
628
629


630

631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
=head2 SQLType attribute

return the SQL type for the attribute 'attribute' as stored in _ClassAccessible

=cut

sub SQLType {
    my $self = shift;
    my $field = shift;

    return ($self->_Accessible($field, 'type'));


}

646
sub __Value {
Jesse Vincent's avatar
Jesse Vincent committed
647
    my $self  = shift;
648
    my $field = shift;
649
    my %args  = ( decode_utf8 => 1, @_ );
650

651
    unless ($field) {
652
        $RT::Logger->error("__Value called with undef field");
653
    }
Jesse Vincent's avatar
Jesse Vincent committed
654

655
    my $value = $self->SUPER::__Value($field);
656
    return $value if ref $value;
657

658
659
    return undef if (!defined $value);

660
661
662
663
664
665
666
667
668
    if ( $args{'decode_utf8'} ) {
        if ( !utf8::is_utf8($value) ) {
            utf8::decode($value);
        }
    }
    else {
        if ( utf8::is_utf8($value) ) {
            utf8::encode($value);
        }
669
    }
670

671
    return $value;
672

673
674
}

675
676
677
678
679
680
681
682
# Set up defaults for DBIx::SearchBuilder::Record::Cachable

sub _CacheConfig {
  {
     'cache_p'        => 1,
     'cache_for_sec'  => 30,
  }
}
683

684

685
686
687

sub _BuildTableAttributes {
    my $self = shift;
688
    my $class = ref($self) || $self;
689

690
691
692
693
694
695
696
    my $attributes;
    if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
       $attributes = $self->_CoreAccessible();
    } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
       $attributes = $self->_ClassAccessible();

    }
697

698
699
    foreach my $column (keys %$attributes) {
        foreach my $attr ( keys %{ $attributes->{$column} } ) {
700
            $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
701
702
        }
    }
703
704
705
    foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
        next unless UNIVERSAL::can( $self, $method );
        $attributes = $self->$method();
706

707
708
        foreach my $column ( keys %$attributes ) {
            foreach my $attr ( keys %{ $attributes->{$column} } ) {
709
                $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
710
711
712
713
714
715
716
717
718
719
            }
        }
    }
}


=head2 _ClassAccessible 

Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
DBIx::SearchBuilder::Record
720
721
722

=cut

723
724
sub _ClassAccessible {
    my $self = shift;
725
    return $_TABLE_ATTR->{ref($self) || $self};
726
727
728
729
730
731
732
733
734
735
736
737
738
}

=head2 _Accessible COLUMN ATTRIBUTE

returns the value of ATTRIBUTE for COLUMN


=cut 

sub _Accessible  {
  my $self = shift;
  my $column = shift;
  my $attribute = lc(shift);
739
740
741
742
743
744

  my $class =  ref($self) || $self;
  $class->_BuildTableAttributes unless ($_TABLE_ATTR->{$class});

  return 0 unless defined ($_TABLE_ATTR->{$class}->{$column});
  return $_TABLE_ATTR->{$class}->{$column}->{$attribute} || 0;
745
746
747

}

748
=head2 _EncodeLOB BODY MIME_TYPE FILENAME
749

750
Takes a potentially large attachment. Returns (ContentEncoding,
751
EncodedBody, MimeType, Filename, NoteArgs) based on system configuration and
752
753
selected database.  Returns a custom (short) text/plain message if
DropLongAttachments causes an attachment to not be stored.
754

755
756
757
758
759
760
761
Encodes your data as base64 or Quoted-Printable as needed based on your
Databases's restrictions and the UTF-8ness of the data being passed in.  Since
we are storing in columns marked UTF8, we must ensure that binary data is
encoded on databases which are strict.

This function expects to receive an octet string in order to properly
evaluate and encode it.  It will return an octet string.
762

763
764
765
766
NoteArgs is currently used to indicate caller that the message is too long and
is truncated or dropped. It's a hashref which is expected to be passed to
L<RT::Record/_NewTransaction>.

767
768
769
=cut

sub _EncodeLOB {
770
771
772
773
    my $self = shift;
    my $Body = shift;
    my $MIMEType = shift || '';
    my $Filename = shift;
774

775
    my $ContentEncoding = 'none';
776
    my $note_args;
777

778
779
    RT::Util::assert_bytes( $Body );

780
781
    #get the max attachment length from RT
    my $MaxSize = RT->Config->Get('MaxAttachmentSize');
782

783
784
    #if the current attachment contains nulls and the
    #database doesn't support embedded nulls
785

786
    if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
787

788
789
        # set a flag telling us to mimencode the attachment
        $ContentEncoding = 'base64';
790

791
792
793
794
795
796
797
798
799
        #cut the max attchment size by 25% (for mime-encoding overhead.
        $RT::Logger->debug("Max size is $MaxSize");
        $MaxSize = $MaxSize * 3 / 4;
    # Some databases (postgres) can't handle non-utf8 data
    } elsif (    !$RT::Handle->BinarySafeBLOBs
              && $Body =~ /\P{ASCII}/
              && !Encode::is_utf8( $Body, 1 ) ) {
          $ContentEncoding = 'quoted-printable';
    }
800

801
802
    #if the attachment is larger than the maximum size
    if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
803

804
        my $size = length $Body;
805
806
        # if we're supposed to truncate large attachments
        if (RT->Config->Get('TruncateLongAttachments')) {
807

808
809
            $RT::Logger->info("$self: Truncated an attachment of size $size");

810
811
            # truncate the attachment to that length.
            $Body = substr( $Body, 0, $MaxSize );
812
813
814
815
816
817
818
            $note_args = {
                Type           => 'AttachmentTruncate',
                Data           => $Filename,
                OldValue       => $size,
                NewValue       => $MaxSize,
                ActivateScrips => 0,
            };
819

820
        }
821

822
823
        # elsif we're supposed to drop large attachments on the floor,
        elsif (RT->Config->Get('DropLongAttachments')) {
824

825
            # drop the attachment on the floor
826
            $RT::Logger->info( "$self: Dropped an attachment of size $size" );
827
            $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
828
829
830
831
832
833
834
835
836
            $note_args = {
                Type           => 'AttachmentDrop',
                Data           => $Filename,
                OldValue       => $size,
                NewValue       => $MaxSize,
                ActivateScrips => 0,
            };
            $Filename .= ".txt" if $Filename && $Filename !~ /\.txt$/;
            return ("none", "Large attachment dropped", "text/plain", $Filename, $note_args );
837
        }
838
    }
839

840
841
842
843
    # if we need to mimencode the attachment
    if ( $ContentEncoding eq 'base64' ) {
        # base64 encode the attachment
        $Body = MIME::Base64::encode_base64($Body);
844

845
846
847
    } elsif ($ContentEncoding eq 'quoted-printable') {
        $Body = MIME::QuotedPrint::encode($Body);
    }
848
849


850
    return ($ContentEncoding, $Body, $MIMEType, $Filename, $note_args );
851
852
}

853
=head2 _DecodeLOB C<ContentType>, C<ContentEncoding>, C<Content>
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868

Unpacks data stored in the database, which may be base64 or QP encoded
because of our need to store binary and badly encoded data in columns
marked as UTF-8.  Databases such as PostgreSQL and Oracle care that you
are feeding them invalid UTF-8 and will refuse the content.  This
function handles unpacking the encoded data.

It returns textual data as a UTF-8 string which has been processed by Encode's
PERLQQ filter which will replace the invalid bytes with \x{HH} so you can see
the invalid byte but won't run into problems treating the data as UTF-8 later.

This is similar to how we filter all data coming in via the web UI in
RT::Interface::Web::DecodeARGS. This filter should only end up being
applied to old data from less UTF-8-safe versions of RT.

869
870
871
872
873
874
If the passed C<ContentType> includes a character set, that will be used
to decode textual data; the default character set is UTF-8.  This is
necessary because while we attempt to store textual data as UTF-8, the
definition of "textual" has migrated over time, and thus we may now need
to attempt to decode data that was previously not trancoded on insertion.

875
876
877
878
879
Important Note - This function expects an octet string and returns a
character string for non-binary data.

=cut

880
881
sub _DecodeLOB {
    my $self            = shift;
Jesse Vincent's avatar
Jesse Vincent committed
882
    my $ContentType     = shift || '';
883
    my $ContentEncoding = shift || 'none';
884
885
    my $Content         = shift;

886
887
    RT::Util::assert_bytes( $Content );

888
889
890
891
892
893
894
895
896
    if ( $ContentEncoding eq 'base64' ) {
        $Content = MIME::Base64::decode_base64($Content);
    }
    elsif ( $ContentEncoding eq 'quoted-printable' ) {
        $Content = MIME::QuotedPrint::decode($Content);
    }
    elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
        return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
    }
897
    if ( RT::I18N::IsTextualContentType($ContentType) ) {
898
899
900
901
902
903
        my $entity = MIME::Entity->new();
        $entity->head->add("Content-Type", $ContentType);
        $entity->bodyhandle( MIME::Body::Scalar->new( $Content ) );
        my $charset = RT::I18N::_FindOrGuessCharset($entity);
        $charset = 'utf-8' if not $charset or not Encode::find_encoding($charset);

904
        $Content = Encode::decode($charset,$Content,Encode::FB_PERLQQ);
905
    }
906
    return ($Content);
907
}
908

909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
=head2 Update  ARGSHASH

Updates fields on an object for you using the proper Set methods,
skipping unchanged values.

 ARGSRef => a hashref of attributes => value for the update
 AttributesRef => an arrayref of keys in ARGSRef that should be updated
 AttributePrefix => a prefix that should be added to the attributes in AttributesRef
                    when looking up values in ARGSRef
                    Bare attributes are tried before prefixed attributes

Returns a list of localized results of the update

=cut

924
925
926
927
sub Update {
    my $self = shift;

    my %args = (
928
929
        ARGSRef         => undef,
        AttributesRef   => undef,
930
931
932
933
934
935
        AttributePrefix => undef,
        @_
    );

    my $attributes = $args{'AttributesRef'};
    my $ARGSRef    = $args{'ARGSRef'};
936
    my %new_values;
937

938
    # gather all new values
939
940
941
942
943
944
    foreach my $attribute (@$attributes) {
        my $value;
        if ( defined $ARGSRef->{$attribute} ) {
            $value = $ARGSRef->{$attribute};
        }
        elsif (
945
946
947
948
            defined( $args{'AttributePrefix'} )
            && defined(
                $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
            )
949
950
951
952
          ) {
            $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };

        }
953
954
955
956
957
958
        else {
            next;
        }

        $value =~ s/\r\n/\n/gs;

959
960
        my $truncated_value = $self->TruncateValue($attribute, $value);

961
962
        # If Queue is 'General', we want to resolve the queue name for
        # the object.
963

964
965
966
        # This is in an eval block because $object might not exist.
        # and might not have a Name method. But "can" won't find autoloaded
        # items. If it fails, we don't care
967
968
969
        do {
            no warnings "uninitialized";
            local $@;
970
            my $name = eval {
971
                my $object = $attribute . "Obj";
972
                $self->$object->Name;
973
            };
974
975
976
            unless ($@) {
                next if $name eq $value || $name eq ($value || 0);
            }
977

Alex Vandiver's avatar
Alex Vandiver committed
978
979
            next if $truncated_value eq $self->$attribute();
            next if ( $truncated_value || 0 ) eq $self->$attribute();
980
        };
981

982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
        $new_values{$attribute} = $value;
    }

    return $self->_UpdateAttributes(
        Attributes => $attributes,
        NewValues  => \%new_values,
    );
}

sub _UpdateAttributes {
    my $self = shift;
    my %args = (
        Attributes => [],
        NewValues  => {},
        @_,
    );

    my @results;