1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2017 Best Practical Solutions, LLC
6 # <sales@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
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
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.
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.
30 # CONTRIBUTION SUBMISSION POLICY:
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.)
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.
47 # END BPS TAGGED BLOCK }}}
51 RT::Record - Base class for RT record objects
70 use base RT->Config->Get('RecordBaseClass');
75 require RT::Attributes;
76 require RT::Transactions;
78 use RT::Shredder::Dependencies;
79 use RT::Shredder::Constants;
80 use RT::Shredder::Exceptions;
82 our $_TABLE_ATTR = { };
83 use base RT->Config->Get('RecordBaseClass');
89 $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
90 $self->CurrentUser(@_);
97 The primary keys for RT classes is 'id'
101 sub _PrimaryKeys { return ['id'] }
102 # short circuit many, many thousands of calls from searchbuilder
103 sub _PrimaryKey { 'id' }
107 Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do
108 on a very common codepath
110 C<id> is an alias to C<Id> and is the preferred way to call this method.
115 return shift->{'values'}->{id};
122 Delete this record object from the database.
128 my ($rv) = $self->SUPER::Delete;
130 return ($rv, $self->loc("Object deleted"));
133 return(0, $self->loc("Object could not be deleted"))
139 Returns a string which is this record's type. It's not localized and by
140 default last part (everything after last ::) of class name is returned.
145 my $res = ref($_[0]) || $_[0];
152 DEPRECATED. Stays here for backwards. Returns localized L</RecordType>.
156 # we deprecate because of:
157 # * ObjectType is used in several classes with ObjectId to store
158 # records of different types, for example transactions use those
159 # and it's unclear what this method should return 'Transaction'
160 # or type of referenced record
161 # * returning localized thing is not good idea
167 Instead => "RecordType",
169 return $self->loc( $self->RecordType( @_ ) );
174 Return this object's attributes as an RT::Attributes object
180 unless ($self->{'attributes'}) {
181 $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
182 $self->{'attributes'}->LimitToObject($self);
183 $self->{'attributes'}->OrderByCols({FIELD => 'id'});
185 return ($self->{'attributes'});
189 =head2 AddAttribute { Name, Description, Content }
191 Adds a new attribute for this object.
197 my %args = ( Name => undef,
198 Description => undef,
202 my $attr = RT::Attribute->new( $self->CurrentUser );
203 my ( $id, $msg ) = $attr->Create(
205 Name => $args{'Name'},
206 Description => $args{'Description'},
207 Content => $args{'Content'} );
210 # XXX TODO: Why won't RedoSearch work here?
211 $self->Attributes->_DoSearch;
217 =head2 SetAttribute { Name, Description, Content }
219 Like AddAttribute, but replaces all existing attributes with the same Name.
225 my %args = ( Name => undef,
226 Description => undef,
230 my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
231 or return $self->AddAttribute( %args );
233 my $AttributeObj = pop( @AttributeObjs );
234 $_->Delete foreach @AttributeObjs;
236 $AttributeObj->SetDescription( $args{'Description'} );
237 $AttributeObj->SetContent( $args{'Content'} );
239 $self->Attributes->RedoSearch;
243 =head2 DeleteAttribute NAME
245 Deletes all attributes with the matching name for this object.
249 sub DeleteAttribute {
252 my ($val,$msg) = $self->Attributes->DeleteEntry( Name => $name );
253 $self->ClearAttributes;
257 =head2 FirstAttribute NAME
259 Returns the first attribute with the matching name for this object (as an
260 L<RT::Attribute> object), or C<undef> if no such attributes exist.
261 If there is more than one attribute with the matching name on the
262 object, the first value that was set is returned.
269 return ($self->Attributes->Named( $name ))[0];
273 sub ClearAttributes {
275 delete $self->{'attributes'};
279 sub _Handle { return $RT::Handle }
283 =head2 Create PARAMHASH
285 Takes a PARAMHASH of Column -> Value pairs.
286 If any Column has a Validate$PARAMNAME subroutine defined and the
287 value provided doesn't pass validation, this routine returns
290 If this object's table has any of the following atetributes defined as
291 'Auto', this routine will automatically fill in their values.
310 foreach my $key ( keys %attribs ) {
311 if (my $method = $self->can("Validate$key")) {
312 if (! $method->( $self, $attribs{$key} ) ) {
314 return ( 0, $self->loc('Invalid value for [_1]', $key) );
325 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime();
328 sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec);
330 $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
332 if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
333 $attribs{'Creator'} = $self->CurrentUser->id || '0';
335 $attribs{'LastUpdated'} = $now_iso
336 if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
338 $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
339 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
341 my $id = $self->SUPER::Create(%attribs);
342 if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
346 $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
353 # If the object was created in the database,
354 # load it up now, so we're sure we get what the database
355 # has. Arguably, this should not be necessary, but there
356 # isn't much we can do about it.
360 return ( $id, $self->loc('Object could not be created') );
368 if (UNIVERSAL::isa('errno',$id)) {
372 $self->Load($id) if ($id);
377 return ( $id, $self->loc('Object created') );
389 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
397 # We don't want to hang onto this
398 $self->ClearAttributes;
400 unless ( $self->_Handle->CaseSensitive ) {
401 my ( $ret, $msg ) = $self->SUPER::LoadByCols( @_ );
402 return wantarray ? ( $ret, $msg ) : $ret;
405 # If this database is case sensitive we need to uncase objects for
408 foreach my $key ( keys %hash ) {
410 # If we've been passed an empty value, we can't do the lookup.
411 # We don't need to explicitly downcase integers or an id.
412 if ( $key ne 'id' && defined $hash{ $key } && $hash{ $key } !~ /^\d+$/ ) {
413 my ($op, $val, $func);
414 ($key, $op, $val, $func) =
415 $self->_Handle->_MakeClauseCaseInsensitive( $key, '=', delete $hash{ $key } );
416 $hash{$key}->{operator} = $op;
417 $hash{$key}->{value} = $val;
418 $hash{$key}->{function} = $func;
421 my ( $ret, $msg ) = $self->SUPER::LoadByCols( %hash );
422 return wantarray ? ( $ret, $msg ) : $ret;
427 # There is room for optimizations in most of those subs:
432 my $obj = RT::Date->new( $self->CurrentUser );
434 $obj->Set( Format => 'sql', Value => $self->LastUpdated );
442 my $obj = RT::Date->new( $self->CurrentUser );
444 $obj->Set( Format => 'sql', Value => $self->Created );
450 # B<DEPRECATED> and will be removed in 4.4
455 Instead => "->CreatedObj->AgeAsString",
457 return ( $self->CreatedObj->AgeAsString() );
460 # B<DEPRECATED> and will be removed in 4.4
461 sub LongSinceUpdateAsString {
465 Instead => "->LastUpdatedObj->AgeAsString",
467 if ( $self->LastUpdated ) {
468 return ( $self->LastUpdatedObj->AgeAsString() );
474 sub LastUpdatedAsString {
476 if ( $self->LastUpdated ) {
477 return ( $self->LastUpdatedObj->AsString() );
483 sub CreatedAsString {
485 return ( $self->CreatedObj->AsString() );
498 #if the user is trying to modify the record
499 # TODO: document _why_ this code is here
501 if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
505 my $old_val = $self->__Value($args{'Field'});
506 $self->_SetLastUpdated();
507 my $ret = $self->SUPER::_Set(
508 Field => $args{'Field'},
509 Value => $args{'Value'},
510 IsSQL => $args{'IsSQL'}
512 my ($status, $msg) = $ret->as_array();
514 # @values has two values, a status code and a message.
516 # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
517 # we want to change the standard "success" message
519 if ($self->SQLType( $args{'Field'}) =~ /text/) {
522 $self->loc( $args{'Field'} ),
526 "[_1] changed from [_2] to [_3]",
527 $self->loc( $args{'Field'} ),
528 ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ),
529 '"' . $self->__Value( $args{'Field'}) . '"',
533 $msg = $self->CurrentUser->loc_fuzzy($msg);
536 return wantarray ? ($status, $msg) : $ret;
541 =head2 _SetLastUpdated
543 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
544 It takes no options. Arguably, this is a bug
548 sub _SetLastUpdated {
550 my $now = RT::Date->new( $self->CurrentUser );
553 if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
554 my ( $msg, $val ) = $self->__Set(
555 Field => 'LastUpdated',
559 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
560 my ( $msg, $val ) = $self->__Set(
561 Field => 'LastUpdatedBy',
562 Value => $self->CurrentUser->id
571 Returns an RT::User object with the RT account of the creator of this row
577 unless ( exists $self->{'CreatorObj'} ) {
579 $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
580 $self->{'CreatorObj'}->Load( $self->Creator );
582 return ( $self->{'CreatorObj'} );
587 =head2 LastUpdatedByObj
589 Returns an RT::User object of the last user to touch this object
593 sub LastUpdatedByObj {
595 unless ( exists $self->{LastUpdatedByObj} ) {
596 $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
597 $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
599 return $self->{'LastUpdatedByObj'};
606 Returns this record's URI
612 my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
613 return($uri->URIForObject($self));
617 =head2 ValidateName NAME
619 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
626 if (defined $value && $value=~ /^\d+$/) {
635 =head2 SQLType attribute
637 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
645 return ($self->_Accessible($field, 'type'));
653 my %args = ( decode_utf8 => 1, @_ );
656 $RT::Logger->error("__Value called with undef field");
659 my $value = $self->SUPER::__Value($field);
660 return $value if ref $value;
662 return undef if (!defined $value);
664 # Pg returns character columns as character strings; mysql and
665 # sqlite return them as bytes. While mysql can be made to return
666 # characters, using the mysql_enable_utf8 flag, the "Content" column
667 # is bytes on mysql and characters on Postgres, making true
668 # consistency impossible.
669 if ( $args{'decode_utf8'} ) {
670 if ( !utf8::is_utf8($value) ) { # mysql/sqlite
671 utf8::decode($value);
674 if ( utf8::is_utf8($value) ) {
675 utf8::encode($value);
683 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
687 'cache_for_sec' => 30,
693 sub _BuildTableAttributes {
695 my $class = ref($self) || $self;
698 if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
699 $attributes = $self->_CoreAccessible();
700 } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
701 $attributes = $self->_ClassAccessible();
705 foreach my $column (keys %$attributes) {
706 foreach my $attr ( keys %{ $attributes->{$column} } ) {
707 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
710 foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
711 next unless UNIVERSAL::can( $self, $method );
712 $attributes = $self->$method();
714 foreach my $column ( keys %$attributes ) {
715 foreach my $attr ( keys %{ $attributes->{$column} } ) {
716 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
723 =head2 _ClassAccessible
725 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
726 DBIx::SearchBuilder::Record
730 sub _ClassAccessible {
732 return $_TABLE_ATTR->{ref($self) || $self};
735 =head2 _Accessible COLUMN ATTRIBUTE
737 returns the value of ATTRIBUTE for COLUMN
745 my $attribute = lc(shift);
747 my $class = ref($self) || $self;
748 $class->_BuildTableAttributes unless ($_TABLE_ATTR->{$class});
750 return 0 unless defined ($_TABLE_ATTR->{$class}->{$column});
751 return $_TABLE_ATTR->{$class}->{$column}->{$attribute} || 0;
755 =head2 _EncodeLOB BODY MIME_TYPE FILENAME
757 Takes a potentially large attachment. Returns (ContentEncoding,
758 EncodedBody, MimeType, Filename, NoteArgs) based on system configuration and
759 selected database. Returns a custom (short) text/plain message if
760 DropLongAttachments causes an attachment to not be stored.
762 Encodes your data as base64 or Quoted-Printable as needed based on your
763 Databases's restrictions and the UTF-8ness of the data being passed in. Since
764 we are storing in columns marked UTF8, we must ensure that binary data is
765 encoded on databases which are strict.
767 This function expects to receive an octet string in order to properly
768 evaluate and encode it. It will return an octet string.
770 NoteArgs is currently used to indicate caller that the message is too long and
771 is truncated or dropped. It's a hashref which is expected to be passed to
772 L<RT::Record/_NewTransaction>.
779 my $MIMEType = shift || '';
780 my $Filename = shift;
782 my $ContentEncoding = 'none';
785 RT::Util::assert_bytes( $Body );
787 #get the max attachment length from RT
788 my $MaxSize = RT->Config->Get('MaxAttachmentSize');
790 #if the current attachment contains nulls and the
791 #database doesn't support embedded nulls
793 if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
795 # set a flag telling us to mimencode the attachment
796 $ContentEncoding = 'base64';
798 #cut the max attchment size by 25% (for mime-encoding overhead.
799 $RT::Logger->debug("Max size is $MaxSize");
800 $MaxSize = $MaxSize * 3 / 4;
801 # Some databases (postgres) can't handle non-utf8 data
802 } elsif ( !$RT::Handle->BinarySafeBLOBs
803 && $Body =~ /\P{ASCII}/
804 && !Encode::is_utf8( $Body, 1 ) ) {
805 $ContentEncoding = 'quoted-printable';
808 #if the attachment is larger than the maximum size
809 if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
811 my $size = length $Body;
812 # if we're supposed to truncate large attachments
813 if (RT->Config->Get('TruncateLongAttachments')) {
815 $RT::Logger->info("$self: Truncated an attachment of size $size");
817 # truncate the attachment to that length.
818 $Body = substr( $Body, 0, $MaxSize );
820 Type => 'AttachmentTruncate',
823 NewValue => $MaxSize,
829 # elsif we're supposed to drop large attachments on the floor,
830 elsif (RT->Config->Get('DropLongAttachments')) {
832 # drop the attachment on the floor
833 $RT::Logger->info( "$self: Dropped an attachment of size $size" );
834 $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
836 Type => 'AttachmentDrop',
839 NewValue => $MaxSize,
842 $Filename .= ".txt" if $Filename && $Filename !~ /\.txt$/;
843 return ("none", "Large attachment dropped", "text/plain", $Filename, $note_args );
847 # if we need to mimencode the attachment
848 if ( $ContentEncoding eq 'base64' ) {
849 # base64 encode the attachment
850 $Body = MIME::Base64::encode_base64($Body);
852 } elsif ($ContentEncoding eq 'quoted-printable') {
853 $Body = MIME::QuotedPrint::encode($Body);
857 return ($ContentEncoding, $Body, $MIMEType, $Filename, $note_args );
860 =head2 _DecodeLOB C<ContentType>, C<ContentEncoding>, C<Content>
862 Unpacks data stored in the database, which may be base64 or QP encoded
863 because of our need to store binary and badly encoded data in columns
864 marked as UTF-8. Databases such as PostgreSQL and Oracle care that you
865 are feeding them invalid UTF-8 and will refuse the content. This
866 function handles unpacking the encoded data.
868 It returns textual data as a UTF-8 string which has been processed by Encode's
869 PERLQQ filter which will replace the invalid bytes with \x{HH} so you can see
870 the invalid byte but won't run into problems treating the data as UTF-8 later.
872 This is similar to how we filter all data coming in via the web UI in
873 RT::Interface::Web::DecodeARGS. This filter should only end up being
874 applied to old data from less UTF-8-safe versions of RT.
876 If the passed C<ContentType> includes a character set, that will be used
877 to decode textual data; the default character set is UTF-8. This is
878 necessary because while we attempt to store textual data as UTF-8, the
879 definition of "textual" has migrated over time, and thus we may now need
880 to attempt to decode data that was previously not trancoded on insertion.
882 Important Note - This function expects an octet string and returns a
883 character string for non-binary data.
889 my $ContentType = shift || '';
890 my $ContentEncoding = shift || 'none';
893 RT::Util::assert_bytes( $Content );
895 if ( $ContentEncoding eq 'base64' ) {
896 $Content = MIME::Base64::decode_base64($Content);
898 elsif ( $ContentEncoding eq 'quoted-printable' ) {
899 $Content = MIME::QuotedPrint::decode($Content);
901 elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
902 return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
904 if ( RT::I18N::IsTextualContentType($ContentType) ) {
905 my $entity = MIME::Entity->new();
906 $entity->head->add("Content-Type", $ContentType);
907 $entity->bodyhandle( MIME::Body::Scalar->new( $Content ) );
908 my $charset = RT::I18N::_FindOrGuessCharset($entity);
909 $charset = 'utf-8' if not $charset or not Encode::find_encoding($charset);
911 $Content = Encode::decode($charset,$Content,Encode::FB_PERLQQ);
916 =head2 Update ARGSHASH
918 Updates fields on an object for you using the proper Set methods,
919 skipping unchanged values.
921 ARGSRef => a hashref of attributes => value for the update
922 AttributesRef => an arrayref of keys in ARGSRef that should be updated
923 AttributePrefix => a prefix that should be added to the attributes in AttributesRef
924 when looking up values in ARGSRef
925 Bare attributes are tried before prefixed attributes
927 Returns a list of localized results of the update
936 AttributesRef => undef,
937 AttributePrefix => undef,
941 my $attributes = $args{'AttributesRef'};
942 my $ARGSRef = $args{'ARGSRef'};
945 # gather all new values
946 foreach my $attribute (@$attributes) {
948 if ( defined $ARGSRef->{$attribute} ) {
949 $value = $ARGSRef->{$attribute};
952 defined( $args{'AttributePrefix'} )
954 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
957 $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
964 $value =~ s/\r\n/\n/gs;
966 my $truncated_value = $self->TruncateValue($attribute, $value);
968 # If Queue is 'General', we want to resolve the queue name for
971 # This is in an eval block because $object might not exist.
972 # and might not have a Name method. But "can" won't find autoloaded
973 # items. If it fails, we don't care
975 no warnings "uninitialized";
978 my $object = $attribute . "Obj";
979 $self->$object->Name;
982 next if $name eq $value || $name eq ($value || 0);
985 next if $truncated_value eq $self->$attribute();
986 next if ( $truncated_value || 0 ) eq $self->$attribute();
989 $new_values{$attribute} = $value;
992 return $self->_UpdateAttributes(
993 Attributes => $attributes,
994 NewValues => \%new_values,
998 sub _UpdateAttributes {
1008 foreach my $attribute (@{ $args{Attributes} }) {
1009 next if !exists($args{NewValues}{$attribute});
1011 my $value = $args{NewValues}{$attribute};
1012 my $method = "Set$attribute";
1013 my ( $code, $msg ) = $self->$method($value);
1014 my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
1016 # Default to $id, but use name if we can get it.
1017 my $label = $self->id;
1018 $label = $self->Name if (UNIVERSAL::can($self,'Name'));
1019 # this requires model names to be loc'ed.
1030 push @results, $self->loc( $prefix ) . " $label: ". $msg;
1034 "[_1] could not be set to [_2].", # loc
1035 "That is already the current value", # loc
1036 "No value sent to _Set!", # loc
1037 "Illegal value for [_1]", # loc
1038 "The new value has been set.", # loc
1039 "No column specified", # loc
1040 "Immutable field", # loc
1041 "Nonexistant field?", # loc
1042 "Invalid data", # loc
1043 "Couldn't find row", # loc
1044 "Missing a primary key?: [_1]", # loc
1045 "Found Object", # loc
1059 This returns an RT::Links object which references all the tickets
1060 which are 'MembersOf' this ticket
1066 return ( $self->_Links( 'Target', 'MemberOf' ) );
1073 This returns an RT::Links object which references all the tickets that this
1074 ticket is a 'MemberOf'
1080 return ( $self->_Links( 'Base', 'MemberOf' ) );
1087 This returns an RT::Links object which shows all references for which this ticket is a base
1093 return ( $self->_Links( 'Base', 'RefersTo' ) );
1100 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1106 return ( $self->_Links( 'Target', 'RefersTo' ) );
1113 This returns an RT::Links object which references all the tickets that depend on this one
1119 return ( $self->_Links( 'Target', 'DependsOn' ) );
1125 =head2 HasUnresolvedDependencies
1127 Takes a paramhash of Type (default to '__any'). Returns the number of
1128 unresolved dependencies, if $self->UnresolvedDependencies returns an
1129 object with one or more members of that type. Returns false
1134 sub HasUnresolvedDependencies {
1141 my $deps = $self->UnresolvedDependencies;
1144 $deps->LimitType( VALUE => $args{Type} );
1149 if ($deps->Count > 0) {
1150 return $deps->Count;
1159 =head2 UnresolvedDependencies
1161 Returns an RT::Tickets object of tickets which this ticket depends on
1162 and which have a status of new, open or stalled. (That list comes from
1163 RT::Queue->ActiveStatusArray
1168 sub UnresolvedDependencies {
1170 my $deps = RT::Tickets->new($self->CurrentUser);
1172 $deps->LimitToActiveStatus;
1173 $deps->LimitDependedOnBy($self->Id);
1181 =head2 AllDependedOnBy
1183 Returns an array of RT::Ticket objects which (directly or indirectly)
1184 depends on this ticket; takes an optional 'Type' argument in the param
1185 hash, which will limit returned tickets to that type, as well as cause
1186 tickets with that type to serve as 'leaf' nodes that stops the recursive
1191 sub AllDependedOnBy {
1193 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1194 Direction => 'Target', @_ );
1199 Returns an array of RT::Ticket objects which this ticket (directly or
1200 indirectly) depends on; takes an optional 'Type' argument in the param
1201 hash, which will limit returned tickets to that type, as well as cause
1202 tickets with that type to serve as 'leaf' nodes that stops the
1203 recursive dependency search.
1209 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1210 Direction => 'Base', @_ );
1213 sub _AllLinkedTickets {
1225 my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1226 while (my $link = $dep->Next()) {
1227 my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1228 next unless ($uri->IsLocal());
1229 my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1230 next if $args{_found}{$obj->Id};
1233 $args{_found}{$obj->Id} = $obj;
1234 $obj->_AllLinkedTickets( %args, _top => 0 );
1236 elsif ($obj->Type and $obj->Type eq $args{Type}) {
1237 $args{_found}{$obj->Id} = $obj;
1240 $obj->_AllLinkedTickets( %args, _top => 0 );
1245 return map { $args{_found}{$_} } sort keys %{$args{_found}};
1256 This returns an RT::Links object which references all the tickets that this ticket depends on
1262 return ( $self->_Links( 'Base', 'DependsOn' ) );
1271 This returns an RT::Links object which references all the customers that
1272 this object is a member of. This includes both explicitly linked customers
1273 and links implied by services.
1278 my( $self, %opt ) = @_;
1279 my $Debug = $opt{'Debug'};
1281 unless ( $self->{'Customers'} ) {
1283 $self->{'Customers'} = $self->MemberOf->Clone;
1285 my $RecordType = $self->RecordType;
1286 my $uri_type = $RecordType eq 'Ticket' ? 'ticket' : "RT::$RecordType";
1288 $self->{'Customers'}->Limit( FIELD => 'Base',
1289 OPERATOR => 'STARTSWITH',
1290 VALUE => 'fsck.com-rt://%/'.$uri_type.'/',
1293 for my $fstable (qw(cust_main cust_svc)) {
1295 $self->{'Customers'}->Limit(
1297 OPERATOR => 'STARTSWITH',
1298 VALUE => "freeside://freeside/$fstable",
1299 ENTRYAGGREGATOR => 'OR',
1300 SUBCLAUSE => 'customers',
1305 warn "->Customers method called on $self; returning ".
1306 ref($self->{'Customers'}). ' object'
1309 return $self->{'Customers'};
1318 This returns an RT::Links object which references all the services this
1319 object is a member of.
1324 my( $self, %opt ) = @_;
1326 unless ( $self->{'Services'} ) {
1328 $self->{'Services'} = $self->MemberOf->Clone;
1330 $self->{'Services'}->Limit(
1332 OPERATOR => 'STARTSWITH',
1333 VALUE => "freeside://freeside/cust_svc",
1337 return $self->{'Services'};
1345 =head2 Links DIRECTION [TYPE]
1347 Return links (L<RT::Links>) to/from this object.
1349 DIRECTION is either 'Base' or 'Target'.
1351 TYPE is a type of links to return, it can be omitted to get
1356 sub Links { shift->_Links(@_) }
1361 #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1364 my $type = shift || "";
1366 unless ( $self->{"$field$type"} ) {
1367 $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1368 # at least to myself
1369 $self->{"$field$type"}->Limit( FIELD => $field,
1370 VALUE => $self->URI,
1371 ENTRYAGGREGATOR => 'OR' );
1372 $self->{"$field$type"}->Limit( FIELD => 'Type',
1376 return ( $self->{"$field$type"} );
1384 Takes a Type and returns a string that is more human readable.
1390 my %args = ( Type => '',
1393 $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1394 $args{Type} =~ s/^\s+//;
1403 Takes either a Target or a Base and returns a string of human friendly text.
1409 my %args = ( Object => undef,
1413 my $text = "URI " . $args{FallBack};
1414 if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1415 $text = "Ticket " . $args{Object}->id;
1422 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1424 If Silent is true then no transactions will be recorded. You can individually
1425 control transactions on both base and target and with SilentBase and
1426 SilentTarget respectively. By default both transactions are created.
1428 If the link destination is a local object and does the
1429 L<RT::Record::Role::Status> role, this method ensures object Status is not
1430 "deleted". Linking to deleted objects is forbidden.
1432 If the link destination (i.e. not C<$self>) is a local object and the
1433 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1434 on the destination object (if any, as returned by the L</ModifyLinkRight>
1435 method). B<< The subclass is expected to check the appropriate right on the
1436 source object (i.e. C<$self>) before calling this method. >> This allows a
1437 different right to be used on the source object during creation, for example.
1439 Returns a tuple of (link ID, message, flag if link already existed).
1451 SilentBase => undef,
1452 SilentTarget => undef,
1456 # Remote_link is the URI of the object that is not this ticket
1460 if ( $args{'Base'} and $args{'Target'} ) {
1461 $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1462 return ( 0, $self->loc("Can't specify both base and target") );
1464 elsif ( $args{'Base'} ) {
1465 $args{'Target'} = $self->URI();
1466 $remote_link = $args{'Base'};
1467 $direction = 'Target';
1469 elsif ( $args{'Target'} ) {
1470 $args{'Base'} = $self->URI();
1471 $remote_link = $args{'Target'};
1472 $direction = 'Base';
1475 return ( 0, $self->loc('Either base or target must be specified') );
1478 my $remote_uri = RT::URI->new( $self->CurrentUser );
1479 if ($remote_uri->FromURI( $remote_link )) {
1480 my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1481 if ($remote_obj and $remote_obj->id) {
1482 # Enforce the remote end of StrictLinkACL
1483 if (RT->Config->Get("StrictLinkACL")) {
1484 my $right = $remote_obj->ModifyLinkRight;
1486 return (0, $self->loc("Permission denied"))
1488 not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1491 # Prevent linking to deleted objects
1492 if ($remote_obj->DOES("RT::Record::Role::Status")
1493 and $remote_obj->Status eq "deleted") {
1494 return (0, $self->loc("Linking to a deleted [_1] is not allowed", $self->loc(lc($remote_obj->RecordType))));
1498 return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1501 # Check if the link already exists - we don't want duplicates
1502 my $old_link = RT::Link->new( $self->CurrentUser );
1503 $old_link->LoadByParams( Base => $args{'Base'},
1504 Type => $args{'Type'},
1505 Target => $args{'Target'} );
1506 if ( $old_link->Id ) {
1507 $RT::Logger->debug("$self Somebody tried to duplicate a link");
1508 return ( $old_link->id, $self->loc("Link already exists"), 1 );
1511 if ( $args{'Type'} =~ /^(?:DependsOn|MemberOf)$/ ) {
1513 my @tickets = $self->_AllLinkedTickets(
1514 LinkType => $args{'Type'},
1515 Direction => $direction eq 'Target' ? 'Base' : 'Target',
1517 if ( grep { $_->id == ( $direction eq 'Target' ? $args{'Base'} : $args{'Target'} ) } @tickets ) {
1518 return ( 0, $self->loc("Refused to add link which would create a circular relationship") );
1522 # Storing the link in the DB.
1523 my $link = RT::Link->new( $self->CurrentUser );
1524 my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1525 Base => $args{Base},
1526 Type => $args{Type} );
1529 $RT::Logger->error("Link could not be created: ".$linkmsg);
1530 return ( 0, $self->loc("Link could not be created: [_1]", $linkmsg) );
1533 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1534 FallBack => $args{Base});
1535 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1536 FallBack => $args{Target});
1537 my $typetext = $self->FormatType(Type => $args{Type});
1538 my $TransString = "$basetext $typetext $targettext.";
1540 # No transactions for you!
1541 return ($linkid, $TransString) if $args{'Silent'};
1543 my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1545 # Some transactions?
1546 unless ( $args{ 'Silent'. $direction } ) {
1547 my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1549 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1550 NewValue => $remote_uri->URI || $remote_link,
1553 $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1556 if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1557 my $OtherObj = $remote_uri->Object;
1558 my ( $val, $msg ) = $OtherObj->_NewTransaction(
1560 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1561 NewValue => $self->URI,
1564 $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1567 return ($linkid, $TransString);
1572 Takes a paramhash of Type and one of Base or Target. Removes that link from this object.
1574 If Silent is true then no transactions will be recorded. You can individually
1575 control transactions on both base and target and with SilentBase and
1576 SilentTarget respectively. By default both transactions are created.
1578 If the link destination (i.e. not C<$self>) is a local object and the
1579 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1580 on the destination object (if any, as returned by the L</ModifyLinkRight>
1581 method). B<< The subclass is expected to check the appropriate right on the
1582 source object (i.e. C<$self>) before calling this method. >>
1584 Returns a tuple of (status flag, message).
1595 SilentBase => undef,
1596 SilentTarget => undef,
1600 # We want one of base and target. We don't care which but we only want _one_.
1604 if ( $args{'Base'} and $args{'Target'} ) {
1605 $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1606 return ( 0, $self->loc("Can't specify both base and target") );
1608 elsif ( $args{'Base'} ) {
1609 $args{'Target'} = $self->URI();
1610 $remote_link = $args{'Base'};
1611 $direction = 'Target';
1613 elsif ( $args{'Target'} ) {
1614 $args{'Base'} = $self->URI();
1615 $remote_link = $args{'Target'};
1616 $direction = 'Base';
1619 $RT::Logger->error("Base or Target must be specified");
1620 return ( 0, $self->loc('Either base or target must be specified') );
1623 my $remote_uri = RT::URI->new( $self->CurrentUser );
1624 if ($remote_uri->FromURI( $remote_link )) {
1625 # Enforce the remote end of StrictLinkACL
1626 my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1627 if ($remote_obj and $remote_obj->id and RT->Config->Get("StrictLinkACL")) {
1628 my $right = $remote_obj->ModifyLinkRight;
1630 return (0, $self->loc("Permission denied"))
1632 not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1635 return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1638 my $link = RT::Link->new( $self->CurrentUser );
1639 $RT::Logger->debug( "Trying to load link: "
1640 . $args{'Base'} . " "
1641 . $args{'Type'} . " "
1642 . $args{'Target'} );
1644 $link->LoadByParams(
1645 Base => $args{'Base'},
1646 Type => $args{'Type'},
1647 Target => $args{'Target'}
1650 unless ($link->id) {
1651 $RT::Logger->debug("Couldn't find that link");
1652 return ( 0, $self->loc("Link not found") );
1655 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1656 FallBack => $args{Base});
1657 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1658 FallBack => $args{Target});
1659 my $typetext = $self->FormatType(Type => $args{Type});
1660 my $TransString = "$basetext no longer $typetext $targettext.";
1662 my ($ok, $msg) = $link->Delete();
1664 RT->Logger->error("Link could not be deleted: $msg");
1665 return ( 0, $self->loc("Link could not be deleted: [_1]", $msg) );
1668 # No transactions for you!
1669 return (1, $TransString) if $args{'Silent'};
1671 my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1673 # Some transactions?
1674 unless ( $args{ 'Silent'. $direction } ) {
1675 my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1676 Type => 'DeleteLink',
1677 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1678 OldValue => $remote_uri->URI || $remote_link,
1681 $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1684 if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1685 my $OtherObj = $remote_uri->Object;
1686 my ( $val, $msg ) = $OtherObj->_NewTransaction(
1687 Type => 'DeleteLink',
1688 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1689 OldValue => $self->URI,
1692 $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1695 return (1, $TransString);
1698 =head1 LockForUpdate
1700 In a database transaction, gains an exclusive lock on the row, to
1701 prevent race conditions. On SQLite, this is a "RESERVED" lock on the
1709 my $pk = $self->_PrimaryKey;
1710 my $id = @_ ? $_[0] : $self->$pk;
1711 $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1712 if (RT->Config->Get('DatabaseType') eq "SQLite") {
1713 # SQLite does DB-level locking, upgrading the transaction to
1714 # "RESERVED" on the first UPDATE/INSERT/DELETE. Do a no-op
1715 # UPDATE to force the upgade.
1716 return RT->DatabaseHandle->dbh->do(
1717 "UPDATE " .$self->Table.
1718 " SET $pk = $pk WHERE 1 = 0");
1720 return $self->_LoadFromSQL(
1721 "SELECT * FROM ".$self->Table
1722 ." WHERE $pk = ? FOR UPDATE",
1728 =head2 _NewTransaction PARAMHASH
1730 Private function to create a new RT::Transaction object for this ticket update
1734 sub _NewTransaction {
1741 OldReference => undef,
1742 NewReference => undef,
1743 ReferenceType => undef,
1747 ActivateScrips => 1,
1749 SquelchMailTo => undef,
1754 my $in_txn = RT->DatabaseHandle->TransactionDepth;
1755 RT->DatabaseHandle->BeginTransaction unless $in_txn;
1757 $self->LockForUpdate;
1759 my $old_ref = $args{'OldReference'};
1760 my $new_ref = $args{'NewReference'};
1761 my $ref_type = $args{'ReferenceType'};
1762 if ($old_ref or $new_ref) {
1763 $ref_type ||= ref($old_ref) || ref($new_ref);
1765 $RT::Logger->error("Reference type not specified for transaction");
1768 $old_ref = $old_ref->Id if ref($old_ref);
1769 $new_ref = $new_ref->Id if ref($new_ref);
1772 require RT::Transaction;
1773 my $trans = RT::Transaction->new( $self->CurrentUser );
1774 my ( $transaction, $msg ) = $trans->Create(
1775 ObjectId => $self->Id,
1776 ObjectType => ref($self),
1777 TimeTaken => $args{'TimeTaken'},
1778 Type => $args{'Type'},
1779 Data => $args{'Data'},
1780 Field => $args{'Field'},
1781 NewValue => $args{'NewValue'},
1782 OldValue => $args{'OldValue'},
1783 NewReference => $new_ref,
1784 OldReference => $old_ref,
1785 ReferenceType => $ref_type,
1786 MIMEObj => $args{'MIMEObj'},
1787 ActivateScrips => $args{'ActivateScrips'},
1788 CommitScrips => $args{'CommitScrips'},
1789 SquelchMailTo => $args{'SquelchMailTo'},
1790 CustomFields => $args{'CustomFields'},
1793 # Rationalize the object since we may have done things to it during the caching.
1794 $self->Load($self->Id);
1796 $RT::Logger->warning($msg) unless $transaction;
1798 $self->_SetLastUpdated;
1800 if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1801 $self->_UpdateTimeTaken( $args{'TimeTaken'}, Transaction => $trans );
1803 if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1804 push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1807 RT->DatabaseHandle->Commit unless $in_txn;
1809 return ( $transaction, $msg, $trans );
1816 Returns an L<RT::Transactions> object of all transactions on this record object
1823 my $transactions = RT::Transactions->new( $self->CurrentUser );
1824 $transactions->Limit(
1825 FIELD => 'ObjectId',
1828 $transactions->Limit(
1829 FIELD => 'ObjectType',
1830 VALUE => ref($self),
1833 return $transactions;
1836 =head2 SortedTransactions
1838 Returns the result of L</Transactions> ordered per the
1839 I<OldestTransactionsFirst> preference/option.
1843 sub SortedTransactions {
1845 my $txns = $self->Transactions;
1846 my $order = RT->Config->Get("OldestTransactionsFirst", $self->CurrentUser)
1849 { FIELD => 'Created', ORDER => $order },
1850 { FIELD => 'id', ORDER => $order },
1855 our %TRANSACTION_CLASSIFICATION = (
1856 Create => 'message',
1857 Correspond => 'message',
1858 Comment => 'message',
1860 AddWatcher => 'people',
1861 DelWatcher => 'people',
1870 DeleteLink => 'links',
1874 __default => 'basics',
1875 map( { $_ => 'dates' } qw(
1876 Told Starts Started Due LastUpdated Created LastUpdated
1878 map( { $_ => 'people' } qw(
1879 Owner Creator LastUpdatedBy
1882 SystemError => 'error',
1883 AttachmentTruncate => 'attachment-truncate',
1884 AttachmentDrop => 'attachment-drop',
1885 AttachmentError => 'error',
1886 __default => 'other',
1889 sub ClassifyTransaction {
1893 my $type = $txn->Type;
1895 my $res = $TRANSACTION_CLASSIFICATION{ $type };
1896 return $res || $TRANSACTION_CLASSIFICATION{ '__default' }
1899 return $res->{ $txn->Field } || $res->{'__default'}
1900 || $TRANSACTION_CLASSIFICATION{ '__default' };
1905 Returns an L<RT::Attachments> object of all attachments on this record object
1906 (for all its L</Transactions>).
1908 By default Content and Headers of attachments are not fetched right away from
1909 database. Use C<WithContent> and C<WithHeaders> options to override this.
1920 my @columns = grep { not /^(Headers|Content)$/ }
1921 RT::Attachment->ReadableAttributes;
1922 push @columns, 'Headers' if $args{'WithHeaders'};
1923 push @columns, 'Content' if $args{'WithContent'};
1925 my $res = RT::Attachments->new( $self->CurrentUser );
1926 $res->Columns( @columns );
1927 my $txn_alias = $res->TransactionAlias;
1929 ALIAS => $txn_alias,
1930 FIELD => 'ObjectType',
1931 VALUE => ref($self),
1934 ALIAS => $txn_alias,
1935 FIELD => 'ObjectId',
1941 =head2 TextAttachments
1943 Returns an L<RT::Attachments> object of all attachments, like L<Attachments>,
1944 but only those that are text.
1946 By default Content and Headers are fetched. Use C<WithContent> and
1947 C<WithHeaders> options to override this.
1951 sub TextAttachments {
1953 my $res = $self->Attachments(
1958 $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text/plain');
1959 $res->Limit( FIELD => 'ContentType', OPERATOR => 'STARTSWITH', VALUE => 'message/');
1960 $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text');
1961 $res->Limit( FIELD => 'Filename', OPERATOR => 'IS', VALUE => 'NULL')
1962 if RT->Config->Get( 'SuppressInlineTextFiles', $self->CurrentUser );
1968 my $cfs = RT::CustomFields->new( $self->CurrentUser );
1970 $cfs->SetContextObject( $self );
1971 # XXX handle multiple types properly
1972 $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1973 $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1974 $cfs->ApplySortOrder;
1979 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1980 # example, for RT::IR::Foo classes.
1982 sub CustomFieldLookupId {
1984 my $lookup = shift || $self->CustomFieldLookupType;
1985 my @classes = ($lookup =~ /RT::(\w+)-/g);
1987 # Work on "RT::Queue", for instance
1988 return $self->Id unless @classes;
1991 # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1992 my $final = shift @classes;
1993 foreach my $class (reverse @classes) {
1994 my $method = "${class}Obj";
1995 $object = $object->$method;
1998 my $id = $object->$final;
1999 unless (defined $id) {
2000 my $method = "${final}Obj";
2001 $id = $object->$method->Id;
2007 =head2 CustomFieldLookupType
2009 Returns the path RT uses to figure out which custom fields apply to this object.
2013 sub CustomFieldLookupType {
2015 return ref($self) || $self;
2019 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
2021 VALUE should be a string. FIELD can be any identifier of a CustomField
2022 supported by L</LoadCustomFieldByIdentifier> method.
2024 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
2025 deletes the old value.
2026 If VALUE is not a valid value for the custom field, returns
2027 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
2028 $id is ID of created L<ObjectCustomFieldValue> object.
2032 sub AddCustomFieldValue {
2034 $self->_AddCustomFieldValue(@_);
2037 sub _AddCustomFieldValue {
2042 LargeContent => undef,
2043 ContentType => undef,
2044 RecordTransaction => 1,
2048 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2049 unless ( $cf->Id ) {
2050 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2053 my $OCFs = $self->CustomFields;
2054 $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
2055 unless ( $OCFs->Count ) {
2059 "Custom field [_1] does not apply to this object",
2060 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
2065 # empty string is not correct value of any CF, so undef it
2066 foreach ( qw(Value LargeContent) ) {
2067 $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
2070 unless ( $cf->ValidateValue( $args{'Value'} ) ) {
2071 return ( 0, $self->loc("Invalid value for custom field") );
2074 # If the custom field only accepts a certain # of values, delete the existing
2075 # value and record a "changed from foo to bar" transaction
2076 unless ( $cf->UnlimitedValues ) {
2078 # Load up a ObjectCustomFieldValues object for this custom field and this ticket
2079 my $values = $cf->ValuesForObject($self);
2081 # We need to whack any old values here. In most cases, the custom field should
2082 # only have one value to delete. In the pathalogical case, this custom field
2083 # used to be a multiple and we have many values to whack....
2084 my $cf_values = $values->Count;
2086 if ( $cf_values > $cf->MaxValues ) {
2087 my $i = 0; #We want to delete all but the max we can currently have , so we can then
2088 # execute the same code to "change" the value from old to new
2089 while ( my $value = $values->Next ) {
2091 if ( $i < $cf_values ) {
2092 my ( $val, $msg ) = $cf->DeleteValueForObject(
2099 my ( $TransactionId, $Msg, $TransactionObj ) =
2100 $self->_NewTransaction(
2101 Type => 'CustomField',
2103 OldReference => $value,
2107 $values->RedoSearch if $i; # redo search if have deleted at least one value
2110 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2114 my $old_value = $values->First;
2116 $old_content = $old_value->Content if $old_value;
2118 my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
2120 Content => $args{'Value'},
2121 LargeContent => $args{'LargeContent'},
2122 ContentType => $args{'ContentType'},
2125 unless ( $new_value_id ) {
2126 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
2129 my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
2130 $new_value->Load( $new_value_id );
2132 # now that adding the new value was successful, delete the old one
2134 my ( $val, $msg ) = $old_value->Delete();
2135 return ( 0, $msg ) unless $val;
2138 if ( $args{'RecordTransaction'} ) {
2139 my ( $TransactionId, $Msg, $TransactionObj ) =
2140 $self->_NewTransaction(
2141 Type => 'CustomField',
2143 OldReference => $old_value,
2144 NewReference => $new_value,
2148 my $new_content = $new_value->Content;
2150 # For datetime, we need to display them in "human" format in result message
2151 #XXX TODO how about date without time?
2152 if ($cf->Type eq 'DateTime') {
2153 my $DateObj = RT::Date->new( $self->CurrentUser );
2156 Value => $new_content,
2158 $new_content = $DateObj->AsString;
2160 if ( defined $old_content && length $old_content ) {
2163 Value => $old_content,
2165 $old_content = $DateObj->AsString;
2169 unless ( defined $old_content && length $old_content ) {
2170 return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
2172 elsif ( !defined $new_content || !length $new_content ) {
2173 return ( $new_value_id,
2174 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
2177 return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
2182 # otherwise, just add a new value and record "new value added"
2184 my $values = $cf->ValuesForObject($self);
2185 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2189 my ($new_value_id, $msg) = $cf->AddValueForObject(
2191 Content => $args{'Value'},
2192 LargeContent => $args{'LargeContent'},
2193 ContentType => $args{'ContentType'},
2196 unless ( $new_value_id ) {
2197 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
2199 if ( $args{'RecordTransaction'} ) {
2200 my ( $tid, $msg ) = $self->_NewTransaction(
2201 Type => 'CustomField',
2203 NewReference => $new_value_id,
2204 ReferenceType => 'RT::ObjectCustomFieldValue',
2207 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
2210 return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
2216 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
2218 Deletes VALUE as a value of CustomField FIELD.
2220 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
2222 If VALUE is not a valid value for the custom field, returns
2223 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
2227 sub DeleteCustomFieldValue {
2236 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2237 unless ( $cf->Id ) {
2238 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2241 my ( $val, $msg ) = $cf->DeleteValueForObject(
2243 Id => $args{'ValueId'},
2244 Content => $args{'Value'},
2250 my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
2251 Type => 'CustomField',
2253 OldReference => $val,
2254 ReferenceType => 'RT::ObjectCustomFieldValue',
2256 unless ($TransactionId) {
2257 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
2260 my $old_value = $TransactionObj->OldValue;
2261 # For datetime, we need to display them in "human" format in result message
2262 if ( $cf->Type eq 'DateTime' ) {
2263 my $DateObj = RT::Date->new( $self->CurrentUser );
2266 Value => $old_value,
2268 $old_value = $DateObj->AsString;
2273 "[_1] is no longer a value for custom field [_2]",
2274 $old_value, $cf->Name
2281 =head2 FirstCustomFieldValue FIELD
2283 Return the content of the first value of CustomField FIELD for this ticket
2284 Takes a field id or name
2288 sub FirstCustomFieldValue {
2292 my $values = $self->CustomFieldValues( $field );
2293 return undef unless my $first = $values->First;
2294 return $first->Content;
2297 =head2 CustomFieldValuesAsString FIELD
2299 Return the content of the CustomField FIELD for this ticket.
2300 If this is a multi-value custom field, values will be joined with newlines.
2302 Takes a field id or name as the first argument
2304 Takes an optional Separator => "," second and third argument
2305 if you want to join the values using something other than a newline
2309 sub CustomFieldValuesAsString {
2313 my $separator = $args{Separator} || "\n";
2315 my $values = $self->CustomFieldValues( $field );
2316 return join ($separator, grep { defined $_ }
2317 map { $_->Content } @{$values->ItemsArrayRef});
2322 =head2 CustomFieldValues FIELD
2324 Return a ObjectCustomFieldValues object of all values of the CustomField whose
2325 id or Name is FIELD for this record.
2327 Returns an RT::ObjectCustomFieldValues object
2331 sub CustomFieldValues {
2336 my $cf = $self->LoadCustomFieldByIdentifier( $field );
2338 # we were asked to search on a custom field we couldn't find
2339 unless ( $cf->id ) {
2340 $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2341 return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2343 return ( $cf->ValuesForObject($self) );
2346 # we're not limiting to a specific custom field;
2347 my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2348 $ocfs->LimitToObject( $self );
2352 =head2 LoadCustomFieldByIdentifier IDENTIFER
2354 Find the custom field has id or name IDENTIFIER for this object.
2356 If no valid field is found, returns an empty RT::CustomField object.
2360 sub LoadCustomFieldByIdentifier {
2365 if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2366 $cf = RT::CustomField->new($self->CurrentUser);
2367 $cf->SetContextObject( $self );
2368 $cf->LoadById( $field->id );
2370 elsif ($field =~ /^\d+$/) {
2371 $cf = RT::CustomField->new($self->CurrentUser);
2372 $cf->SetContextObject( $self );
2373 $cf->LoadById($field);
2376 my $cfs = $self->CustomFields($self->CurrentUser);
2377 $cfs->SetContextObject( $self );
2378 $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2379 $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2384 sub ACLEquivalenceObjects { }
2388 Takes a paramhash with the attributes 'Right' and 'Principal'
2389 'Right' is a ticket-scoped textual right from RT::ACE
2390 'Principal' is an RT::User object
2392 Returns 1 if the principal has the right. Returns undef if not.
2404 $args{Principal} ||= $self->CurrentUser->PrincipalObj;
2406 return $args{'Principal'}->HasRight(
2407 Object => $self->Id ? $self : $RT::System,
2408 Right => $args{'Right'}
2412 sub CurrentUserHasRight {
2414 return $self->HasRight( Right => @_ );
2417 sub ModifyLinkRight { }
2419 =head2 ColumnMapClassName
2421 ColumnMap needs a massaged collection class name to load the correct list
2422 display. Equivalent to L<RT::SearchBuilder/ColumnMapClassName>, but provided
2423 for a record instead of a collection.
2425 Returns a string. May be called as a package method.
2429 sub ColumnMapClassName {
2431 my $Class = ref($self) || $self;
2436 sub BasicColumns { }
2439 return RT->Config->Get('WebPath'). "/index.html?q=";
2444 return undef unless defined $self->Id;
2445 return "@{[ref $self]}-$RT::Organization-@{[$self->Id]}";
2448 sub FindDependencies {
2450 my ($walker, $deps) = @_;
2451 for my $col (qw/Creator LastUpdatedBy/) {
2452 if ( $self->_Accessible( $col, 'read' ) ) {
2453 next unless $self->$col;
2454 my $obj = RT::Principal->new( $self->CurrentUser );
2455 $obj->Load( $self->$col );
2456 $deps->Add( out => $obj->Object );
2460 # Object attributes, we have to check on every object
2461 my $objs = $self->Attributes;
2462 $deps->Add( in => $objs );
2465 if ( $self->isa("RT::Ticket")
2466 or $self->isa("RT::User")
2467 or $self->isa("RT::Group")
2468 or $self->isa("RT::Article")
2469 or $self->isa("RT::Queue") )
2471 $objs = RT::Transactions->new( $self->CurrentUser );
2472 $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2473 $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2474 $deps->Add( in => $objs );
2477 # Object custom field values
2478 if (( $self->isa("RT::Transaction")
2479 or $self->isa("RT::Ticket")
2480 or $self->isa("RT::User")
2481 or $self->isa("RT::Group")
2482 or $self->isa("RT::Queue")
2483 or $self->isa("RT::Article") )
2484 and $self->can("CustomFieldValues") )
2486 $objs = $self->CustomFieldValues; # Actually OCFVs
2487 $objs->{find_expired_rows} = 1;
2488 $deps->Add( in => $objs );
2492 if ( $self->isa("RT::Group")
2493 or $self->isa("RT::Class")
2494 or $self->isa("RT::Queue")
2495 or $self->isa("RT::CustomField") )
2497 $objs = RT::ACL->new( $self->CurrentUser );
2498 $objs->LimitToObject( $self );
2499 $deps->Add( in => $objs );
2511 Creator => "CreatorObj",
2512 LastUpdatedBy => "LastUpdatedByObj",
2513 %{ $args{Methods} || {} },
2516 my %values = %{$self->{values}};
2518 my %ca = %{ $self->_ClassAccessible };
2519 my @cols = grep {exists $values{lc $_} and defined $values{lc $_}} keys %ca;
2522 $store{$_} = $values{lc $_} for @cols;
2523 $store{id} = $values{id}; # Explicitly necessary in some cases
2525 # Un-apply the _transfer_ encoding, but don't mess with the octets
2526 # themselves. Calling ->Content directly would, in some cases,
2527 # decode from some mostly-unknown character set -- which reversing
2528 # on the far end would be complicated.
2529 if ($ca{ContentEncoding} and $ca{ContentType}) {
2530 my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2531 $store{$content_col} = $self->_DecodeLOB(
2532 "application/octet-stream", # Lie so that we get bytes, not characters
2533 $self->ContentEncoding,
2534 $self->_Value( $content_col, decode_utf8 => 0 )
2536 delete $store{ContentEncoding};
2538 return %store unless $args{UIDs};
2540 # Use FooObj to turn Foo into a reference to the UID
2541 for my $col ( grep {$store{$_}} @cols ) {
2542 my $method = $methods{$col};
2545 $method =~ s/(Id)?$/Obj/;
2547 next unless $self->can($method);
2549 my $obj = $self->$method;
2550 next unless $obj and $obj->isa("RT::Record");
2551 $store{$col} = \($obj->UID);
2554 # Anything on an object should get the UID stored instead
2555 if ($store{ObjectType} and $store{ObjectId} and $self->can("Object")) {
2556 delete $store{$_} for qw/ObjectType ObjectId/;
2557 $store{Object} = \($self->Object->UID);
2565 my ($importer, $uid, $data) = @_;
2567 my $ca = $class->_ClassAccessible;
2570 if ($ca{ContentEncoding} and $ca{ContentType}) {
2571 my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2572 if (defined $data->{$content_col}) {
2573 my ($ContentEncoding, $Content) = $class->_EncodeLOB(
2574 $data->{$content_col}, $data->{ContentType},
2576 $data->{ContentEncoding} = $ContentEncoding;
2577 $data->{$content_col} = $Content;
2581 if ($data->{Object} and not $ca{Object}) {
2582 my $ref_uid = ${ delete $data->{Object} };
2583 my $ref = $importer->Lookup( $ref_uid );
2585 my ($class, $id) = @{$ref};
2586 $data->{ObjectId} = $id;
2587 $data->{ObjectType} = $class;
2589 $data->{ObjectId} = 0;
2590 $data->{ObjectType} = "";
2591 $importer->Postpone(
2594 column => "ObjectId",
2595 classcolumn => "ObjectType",
2600 for my $col (keys %{$data}) {
2601 if (ref $data->{$col}) {
2602 my $ref_uid = ${ $data->{$col} };
2603 my $ref = $importer->Lookup( $ref_uid );
2605 my (undef, $id) = @{$ref};
2606 $data->{$col} = $id;
2609 $importer->Postpone(
2624 =head2 _AsInsertQuery
2626 Returns INSERT query string that duplicates current record and
2627 can be used to insert record back into DB after delete.
2635 my $dbh = $RT::Handle->dbh;
2637 my $res = "INSERT INTO ". $dbh->quote_identifier( $self->Table );
2638 my $values = $self->{'values'};
2639 $res .= "(". join( ",", map { $dbh->quote_identifier( $_ ) } sort keys %$values ) .")";
2641 $res .= "(". join( ",", map { $dbh->quote( $values->{$_} ) } sort keys %$values ) .")";
2647 sub BeforeWipeout { return 1 }
2651 Returns L<RT::Shredder::Dependencies> object.
2660 Flags => RT::Shredder::Constants::DEPENDS_ON,
2664 unless( $self->id ) {
2665 RT::Shredder::Exception->throw('Object is not loaded');
2668 my $deps = RT::Shredder::Dependencies->new();
2669 if( $args{'Flags'} & RT::Shredder::Constants::DEPENDS_ON ) {
2670 $self->__DependsOn( %args, Dependencies => $deps );
2680 Dependencies => undef,
2683 my $deps = $args{'Dependencies'};
2686 # Object custom field values
2687 my $objs = $self->CustomFieldValues;
2688 $objs->{'find_expired_rows'} = 1;
2689 push( @$list, $objs );
2692 $objs = $self->Attributes;
2693 push( @$list, $objs );
2696 $objs = RT::Transactions->new( $self->CurrentUser );
2697 $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2698 $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2699 push( @$list, $objs );
2702 if ( $self->can('Links') ) {
2703 # make sure we don't skip any record
2704 no warnings 'redefine';
2705 local *RT::Links::IsValidLink = sub { 1 };
2707 foreach ( qw(Base Target) ) {
2708 my $objs = $self->Links( $_ );
2710 push @$list, $objs->ItemsArrayRef;
2715 $objs = RT::ACL->new( $self->CurrentUser );
2716 $objs->LimitToObject( $self );
2717 push( @$list, $objs );
2719 $deps->_PushDependencies(
2720 BaseObject => $self,
2721 Flags => RT::Shredder::Constants::DEPENDS_ON,
2722 TargetObjects => $list,
2723 Shredder => $args{'Shredder'}
2728 # implement proxy method because some RT classes
2729 # override Delete method
2733 my $msg = $self->UID ." wiped out";
2734 $self->SUPER::Delete;
2735 $RT::Logger->info( $msg );
2739 RT::Base->_ImportOverlays();