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 $self->{'Customers'}->Limit( FIELD => 'Base',
1286 OPERATOR => 'STARTSWITH',
1287 VALUE => 'fsck.com-rt://%/ticket/',
1290 for my $fstable (qw(cust_main cust_svc)) {
1292 $self->{'Customers'}->Limit(
1294 OPERATOR => 'STARTSWITH',
1295 VALUE => "freeside://freeside/$fstable",
1296 ENTRYAGGREGATOR => 'OR',
1297 SUBCLAUSE => 'customers',
1302 warn "->Customers method called on $self; returning ".
1303 ref($self->{'Customers'}). ' object'
1306 return $self->{'Customers'};
1315 This returns an RT::Links object which references all the services this
1316 object is a member of.
1321 my( $self, %opt ) = @_;
1323 unless ( $self->{'Services'} ) {
1325 $self->{'Services'} = $self->MemberOf->Clone;
1327 $self->{'Services'}->Limit(
1329 OPERATOR => 'STARTSWITH',
1330 VALUE => "freeside://freeside/cust_svc",
1334 return $self->{'Services'};
1342 =head2 Links DIRECTION [TYPE]
1344 Return links (L<RT::Links>) to/from this object.
1346 DIRECTION is either 'Base' or 'Target'.
1348 TYPE is a type of links to return, it can be omitted to get
1353 sub Links { shift->_Links(@_) }
1358 #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1361 my $type = shift || "";
1363 unless ( $self->{"$field$type"} ) {
1364 $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1365 # at least to myself
1366 $self->{"$field$type"}->Limit( FIELD => $field,
1367 VALUE => $self->URI,
1368 ENTRYAGGREGATOR => 'OR' );
1369 $self->{"$field$type"}->Limit( FIELD => 'Type',
1373 return ( $self->{"$field$type"} );
1381 Takes a Type and returns a string that is more human readable.
1387 my %args = ( Type => '',
1390 $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1391 $args{Type} =~ s/^\s+//;
1400 Takes either a Target or a Base and returns a string of human friendly text.
1406 my %args = ( Object => undef,
1410 my $text = "URI " . $args{FallBack};
1411 if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1412 $text = "Ticket " . $args{Object}->id;
1419 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1421 If Silent is true then no transactions will be recorded. You can individually
1422 control transactions on both base and target and with SilentBase and
1423 SilentTarget respectively. By default both transactions are created.
1425 If the link destination is a local object and does the
1426 L<RT::Record::Role::Status> role, this method ensures object Status is not
1427 "deleted". Linking to deleted objects is forbidden.
1429 If the link destination (i.e. not C<$self>) is a local object and the
1430 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1431 on the destination object (if any, as returned by the L</ModifyLinkRight>
1432 method). B<< The subclass is expected to check the appropriate right on the
1433 source object (i.e. C<$self>) before calling this method. >> This allows a
1434 different right to be used on the source object during creation, for example.
1436 Returns a tuple of (link ID, message, flag if link already existed).
1448 SilentBase => undef,
1449 SilentTarget => undef,
1453 # Remote_link is the URI of the object that is not this ticket
1457 if ( $args{'Base'} and $args{'Target'} ) {
1458 $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1459 return ( 0, $self->loc("Can't specify both base and target") );
1461 elsif ( $args{'Base'} ) {
1462 $args{'Target'} = $self->URI();
1463 $remote_link = $args{'Base'};
1464 $direction = 'Target';
1466 elsif ( $args{'Target'} ) {
1467 $args{'Base'} = $self->URI();
1468 $remote_link = $args{'Target'};
1469 $direction = 'Base';
1472 return ( 0, $self->loc('Either base or target must be specified') );
1475 my $remote_uri = RT::URI->new( $self->CurrentUser );
1476 if ($remote_uri->FromURI( $remote_link )) {
1477 my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1478 if ($remote_obj and $remote_obj->id) {
1479 # Enforce the remote end of StrictLinkACL
1480 if (RT->Config->Get("StrictLinkACL")) {
1481 my $right = $remote_obj->ModifyLinkRight;
1483 return (0, $self->loc("Permission denied"))
1485 not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1488 # Prevent linking to deleted objects
1489 if ($remote_obj->DOES("RT::Record::Role::Status")
1490 and $remote_obj->Status eq "deleted") {
1491 return (0, $self->loc("Linking to a deleted [_1] is not allowed", $self->loc(lc($remote_obj->RecordType))));
1495 return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1498 # Check if the link already exists - we don't want duplicates
1499 my $old_link = RT::Link->new( $self->CurrentUser );
1500 $old_link->LoadByParams( Base => $args{'Base'},
1501 Type => $args{'Type'},
1502 Target => $args{'Target'} );
1503 if ( $old_link->Id ) {
1504 $RT::Logger->debug("$self Somebody tried to duplicate a link");
1505 return ( $old_link->id, $self->loc("Link already exists"), 1 );
1508 if ( $args{'Type'} =~ /^(?:DependsOn|MemberOf)$/ ) {
1510 my @tickets = $self->_AllLinkedTickets(
1511 LinkType => $args{'Type'},
1512 Direction => $direction eq 'Target' ? 'Base' : 'Target',
1514 if ( grep { $_->id == ( $direction eq 'Target' ? $args{'Base'} : $args{'Target'} ) } @tickets ) {
1515 return ( 0, $self->loc("Refused to add link which would create a circular relationship") );
1519 # Storing the link in the DB.
1520 my $link = RT::Link->new( $self->CurrentUser );
1521 my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1522 Base => $args{Base},
1523 Type => $args{Type} );
1526 $RT::Logger->error("Link could not be created: ".$linkmsg);
1527 return ( 0, $self->loc("Link could not be created: [_1]", $linkmsg) );
1530 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1531 FallBack => $args{Base});
1532 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1533 FallBack => $args{Target});
1534 my $typetext = $self->FormatType(Type => $args{Type});
1535 my $TransString = "$basetext $typetext $targettext.";
1537 # No transactions for you!
1538 return ($linkid, $TransString) if $args{'Silent'};
1540 my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1542 # Some transactions?
1543 unless ( $args{ 'Silent'. $direction } ) {
1544 my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1546 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1547 NewValue => $remote_uri->URI || $remote_link,
1550 $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1553 if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1554 my $OtherObj = $remote_uri->Object;
1555 my ( $val, $msg ) = $OtherObj->_NewTransaction(
1557 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1558 NewValue => $self->URI,
1561 $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1564 return ($linkid, $TransString);
1569 Takes a paramhash of Type and one of Base or Target. Removes that link from this object.
1571 If Silent is true then no transactions will be recorded. You can individually
1572 control transactions on both base and target and with SilentBase and
1573 SilentTarget respectively. By default both transactions are created.
1575 If the link destination (i.e. not C<$self>) is a local object and the
1576 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1577 on the destination object (if any, as returned by the L</ModifyLinkRight>
1578 method). B<< The subclass is expected to check the appropriate right on the
1579 source object (i.e. C<$self>) before calling this method. >>
1581 Returns a tuple of (status flag, message).
1592 SilentBase => undef,
1593 SilentTarget => undef,
1597 # We want one of base and target. We don't care which but we only want _one_.
1601 if ( $args{'Base'} and $args{'Target'} ) {
1602 $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1603 return ( 0, $self->loc("Can't specify both base and target") );
1605 elsif ( $args{'Base'} ) {
1606 $args{'Target'} = $self->URI();
1607 $remote_link = $args{'Base'};
1608 $direction = 'Target';
1610 elsif ( $args{'Target'} ) {
1611 $args{'Base'} = $self->URI();
1612 $remote_link = $args{'Target'};
1613 $direction = 'Base';
1616 $RT::Logger->error("Base or Target must be specified");
1617 return ( 0, $self->loc('Either base or target must be specified') );
1620 my $remote_uri = RT::URI->new( $self->CurrentUser );
1621 if ($remote_uri->FromURI( $remote_link )) {
1622 # Enforce the remote end of StrictLinkACL
1623 my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1624 if ($remote_obj and $remote_obj->id and RT->Config->Get("StrictLinkACL")) {
1625 my $right = $remote_obj->ModifyLinkRight;
1627 return (0, $self->loc("Permission denied"))
1629 not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1632 return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1635 my $link = RT::Link->new( $self->CurrentUser );
1636 $RT::Logger->debug( "Trying to load link: "
1637 . $args{'Base'} . " "
1638 . $args{'Type'} . " "
1639 . $args{'Target'} );
1641 $link->LoadByParams(
1642 Base => $args{'Base'},
1643 Type => $args{'Type'},
1644 Target => $args{'Target'}
1647 unless ($link->id) {
1648 $RT::Logger->debug("Couldn't find that link");
1649 return ( 0, $self->loc("Link not found") );
1652 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1653 FallBack => $args{Base});
1654 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1655 FallBack => $args{Target});
1656 my $typetext = $self->FormatType(Type => $args{Type});
1657 my $TransString = "$basetext no longer $typetext $targettext.";
1659 my ($ok, $msg) = $link->Delete();
1661 RT->Logger->error("Link could not be deleted: $msg");
1662 return ( 0, $self->loc("Link could not be deleted: [_1]", $msg) );
1665 # No transactions for you!
1666 return (1, $TransString) if $args{'Silent'};
1668 my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1670 # Some transactions?
1671 unless ( $args{ 'Silent'. $direction } ) {
1672 my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1673 Type => 'DeleteLink',
1674 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1675 OldValue => $remote_uri->URI || $remote_link,
1678 $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1681 if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1682 my $OtherObj = $remote_uri->Object;
1683 my ( $val, $msg ) = $OtherObj->_NewTransaction(
1684 Type => 'DeleteLink',
1685 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1686 OldValue => $self->URI,
1689 $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1692 return (1, $TransString);
1695 =head1 LockForUpdate
1697 In a database transaction, gains an exclusive lock on the row, to
1698 prevent race conditions. On SQLite, this is a "RESERVED" lock on the
1706 my $pk = $self->_PrimaryKey;
1707 my $id = @_ ? $_[0] : $self->$pk;
1708 $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1709 if (RT->Config->Get('DatabaseType') eq "SQLite") {
1710 # SQLite does DB-level locking, upgrading the transaction to
1711 # "RESERVED" on the first UPDATE/INSERT/DELETE. Do a no-op
1712 # UPDATE to force the upgade.
1713 return RT->DatabaseHandle->dbh->do(
1714 "UPDATE " .$self->Table.
1715 " SET $pk = $pk WHERE 1 = 0");
1717 return $self->_LoadFromSQL(
1718 "SELECT * FROM ".$self->Table
1719 ." WHERE $pk = ? FOR UPDATE",
1725 =head2 _NewTransaction PARAMHASH
1727 Private function to create a new RT::Transaction object for this ticket update
1731 sub _NewTransaction {
1738 OldReference => undef,
1739 NewReference => undef,
1740 ReferenceType => undef,
1744 ActivateScrips => 1,
1746 SquelchMailTo => undef,
1751 my $in_txn = RT->DatabaseHandle->TransactionDepth;
1752 RT->DatabaseHandle->BeginTransaction unless $in_txn;
1754 $self->LockForUpdate;
1756 my $old_ref = $args{'OldReference'};
1757 my $new_ref = $args{'NewReference'};
1758 my $ref_type = $args{'ReferenceType'};
1759 if ($old_ref or $new_ref) {
1760 $ref_type ||= ref($old_ref) || ref($new_ref);
1762 $RT::Logger->error("Reference type not specified for transaction");
1765 $old_ref = $old_ref->Id if ref($old_ref);
1766 $new_ref = $new_ref->Id if ref($new_ref);
1769 require RT::Transaction;
1770 my $trans = RT::Transaction->new( $self->CurrentUser );
1771 my ( $transaction, $msg ) = $trans->Create(
1772 ObjectId => $self->Id,
1773 ObjectType => ref($self),
1774 TimeTaken => $args{'TimeTaken'},
1775 Type => $args{'Type'},
1776 Data => $args{'Data'},
1777 Field => $args{'Field'},
1778 NewValue => $args{'NewValue'},
1779 OldValue => $args{'OldValue'},
1780 NewReference => $new_ref,
1781 OldReference => $old_ref,
1782 ReferenceType => $ref_type,
1783 MIMEObj => $args{'MIMEObj'},
1784 ActivateScrips => $args{'ActivateScrips'},
1785 CommitScrips => $args{'CommitScrips'},
1786 SquelchMailTo => $args{'SquelchMailTo'},
1787 CustomFields => $args{'CustomFields'},
1790 # Rationalize the object since we may have done things to it during the caching.
1791 $self->Load($self->Id);
1793 $RT::Logger->warning($msg) unless $transaction;
1795 $self->_SetLastUpdated;
1797 if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1798 $self->_UpdateTimeTaken( $args{'TimeTaken'}, Transaction => $trans );
1800 if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1801 push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1804 RT->DatabaseHandle->Commit unless $in_txn;
1806 return ( $transaction, $msg, $trans );
1813 Returns an L<RT::Transactions> object of all transactions on this record object
1820 my $transactions = RT::Transactions->new( $self->CurrentUser );
1821 $transactions->Limit(
1822 FIELD => 'ObjectId',
1825 $transactions->Limit(
1826 FIELD => 'ObjectType',
1827 VALUE => ref($self),
1830 return $transactions;
1833 =head2 SortedTransactions
1835 Returns the result of L</Transactions> ordered per the
1836 I<OldestTransactionsFirst> preference/option.
1840 sub SortedTransactions {
1842 my $txns = $self->Transactions;
1843 my $order = RT->Config->Get("OldestTransactionsFirst", $self->CurrentUser)
1846 { FIELD => 'Created', ORDER => $order },
1847 { FIELD => 'id', ORDER => $order },
1852 our %TRANSACTION_CLASSIFICATION = (
1853 Create => 'message',
1854 Correspond => 'message',
1855 Comment => 'message',
1857 AddWatcher => 'people',
1858 DelWatcher => 'people',
1867 DeleteLink => 'links',
1871 __default => 'basics',
1872 map( { $_ => 'dates' } qw(
1873 Told Starts Started Due LastUpdated Created LastUpdated
1875 map( { $_ => 'people' } qw(
1876 Owner Creator LastUpdatedBy
1879 SystemError => 'error',
1880 AttachmentTruncate => 'attachment-truncate',
1881 AttachmentDrop => 'attachment-drop',
1882 AttachmentError => 'error',
1883 __default => 'other',
1886 sub ClassifyTransaction {
1890 my $type = $txn->Type;
1892 my $res = $TRANSACTION_CLASSIFICATION{ $type };
1893 return $res || $TRANSACTION_CLASSIFICATION{ '__default' }
1896 return $res->{ $txn->Field } || $res->{'__default'}
1897 || $TRANSACTION_CLASSIFICATION{ '__default' };
1902 Returns an L<RT::Attachments> object of all attachments on this record object
1903 (for all its L</Transactions>).
1905 By default Content and Headers of attachments are not fetched right away from
1906 database. Use C<WithContent> and C<WithHeaders> options to override this.
1917 my @columns = grep { not /^(Headers|Content)$/ }
1918 RT::Attachment->ReadableAttributes;
1919 push @columns, 'Headers' if $args{'WithHeaders'};
1920 push @columns, 'Content' if $args{'WithContent'};
1922 my $res = RT::Attachments->new( $self->CurrentUser );
1923 $res->Columns( @columns );
1924 my $txn_alias = $res->TransactionAlias;
1926 ALIAS => $txn_alias,
1927 FIELD => 'ObjectType',
1928 VALUE => ref($self),
1931 ALIAS => $txn_alias,
1932 FIELD => 'ObjectId',
1938 =head2 TextAttachments
1940 Returns an L<RT::Attachments> object of all attachments, like L<Attachments>,
1941 but only those that are text.
1943 By default Content and Headers are fetched. Use C<WithContent> and
1944 C<WithHeaders> options to override this.
1948 sub TextAttachments {
1950 my $res = $self->Attachments(
1955 $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text/plain');
1956 $res->Limit( FIELD => 'ContentType', OPERATOR => 'STARTSWITH', VALUE => 'message/');
1957 $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text');
1958 $res->Limit( FIELD => 'Filename', OPERATOR => 'IS', VALUE => 'NULL')
1959 if RT->Config->Get( 'SuppressInlineTextFiles', $self->CurrentUser );
1965 my $cfs = RT::CustomFields->new( $self->CurrentUser );
1967 $cfs->SetContextObject( $self );
1968 # XXX handle multiple types properly
1969 $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1970 $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1971 $cfs->ApplySortOrder;
1976 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1977 # example, for RT::IR::Foo classes.
1979 sub CustomFieldLookupId {
1981 my $lookup = shift || $self->CustomFieldLookupType;
1982 my @classes = ($lookup =~ /RT::(\w+)-/g);
1984 # Work on "RT::Queue", for instance
1985 return $self->Id unless @classes;
1988 # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1989 my $final = shift @classes;
1990 foreach my $class (reverse @classes) {
1991 my $method = "${class}Obj";
1992 $object = $object->$method;
1995 my $id = $object->$final;
1996 unless (defined $id) {
1997 my $method = "${final}Obj";
1998 $id = $object->$method->Id;
2004 =head2 CustomFieldLookupType
2006 Returns the path RT uses to figure out which custom fields apply to this object.
2010 sub CustomFieldLookupType {
2012 return ref($self) || $self;
2016 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
2018 VALUE should be a string. FIELD can be any identifier of a CustomField
2019 supported by L</LoadCustomFieldByIdentifier> method.
2021 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
2022 deletes the old value.
2023 If VALUE is not a valid value for the custom field, returns
2024 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
2025 $id is ID of created L<ObjectCustomFieldValue> object.
2029 sub AddCustomFieldValue {
2031 $self->_AddCustomFieldValue(@_);
2034 sub _AddCustomFieldValue {
2039 LargeContent => undef,
2040 ContentType => undef,
2041 RecordTransaction => 1,
2045 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2046 unless ( $cf->Id ) {
2047 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2050 my $OCFs = $self->CustomFields;
2051 $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
2052 unless ( $OCFs->Count ) {
2056 "Custom field [_1] does not apply to this object",
2057 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
2062 # empty string is not correct value of any CF, so undef it
2063 foreach ( qw(Value LargeContent) ) {
2064 $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
2067 unless ( $cf->ValidateValue( $args{'Value'} ) ) {
2068 return ( 0, $self->loc("Invalid value for custom field") );
2071 # If the custom field only accepts a certain # of values, delete the existing
2072 # value and record a "changed from foo to bar" transaction
2073 unless ( $cf->UnlimitedValues ) {
2075 # Load up a ObjectCustomFieldValues object for this custom field and this ticket
2076 my $values = $cf->ValuesForObject($self);
2078 # We need to whack any old values here. In most cases, the custom field should
2079 # only have one value to delete. In the pathalogical case, this custom field
2080 # used to be a multiple and we have many values to whack....
2081 my $cf_values = $values->Count;
2083 if ( $cf_values > $cf->MaxValues ) {
2084 my $i = 0; #We want to delete all but the max we can currently have , so we can then
2085 # execute the same code to "change" the value from old to new
2086 while ( my $value = $values->Next ) {
2088 if ( $i < $cf_values ) {
2089 my ( $val, $msg ) = $cf->DeleteValueForObject(
2096 my ( $TransactionId, $Msg, $TransactionObj ) =
2097 $self->_NewTransaction(
2098 Type => 'CustomField',
2100 OldReference => $value,
2104 $values->RedoSearch if $i; # redo search if have deleted at least one value
2107 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2111 my $old_value = $values->First;
2113 $old_content = $old_value->Content if $old_value;
2115 my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
2117 Content => $args{'Value'},
2118 LargeContent => $args{'LargeContent'},
2119 ContentType => $args{'ContentType'},
2122 unless ( $new_value_id ) {
2123 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
2126 my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
2127 $new_value->Load( $new_value_id );
2129 # now that adding the new value was successful, delete the old one
2131 my ( $val, $msg ) = $old_value->Delete();
2132 return ( 0, $msg ) unless $val;
2135 if ( $args{'RecordTransaction'} ) {
2136 my ( $TransactionId, $Msg, $TransactionObj ) =
2137 $self->_NewTransaction(
2138 Type => 'CustomField',
2140 OldReference => $old_value,
2141 NewReference => $new_value,
2145 my $new_content = $new_value->Content;
2147 # For datetime, we need to display them in "human" format in result message
2148 #XXX TODO how about date without time?
2149 if ($cf->Type eq 'DateTime') {
2150 my $DateObj = RT::Date->new( $self->CurrentUser );
2153 Value => $new_content,
2155 $new_content = $DateObj->AsString;
2157 if ( defined $old_content && length $old_content ) {
2160 Value => $old_content,
2162 $old_content = $DateObj->AsString;
2166 unless ( defined $old_content && length $old_content ) {
2167 return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
2169 elsif ( !defined $new_content || !length $new_content ) {
2170 return ( $new_value_id,
2171 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
2174 return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
2179 # otherwise, just add a new value and record "new value added"
2181 my $values = $cf->ValuesForObject($self);
2182 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2186 my ($new_value_id, $msg) = $cf->AddValueForObject(
2188 Content => $args{'Value'},
2189 LargeContent => $args{'LargeContent'},
2190 ContentType => $args{'ContentType'},
2193 unless ( $new_value_id ) {
2194 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
2196 if ( $args{'RecordTransaction'} ) {
2197 my ( $tid, $msg ) = $self->_NewTransaction(
2198 Type => 'CustomField',
2200 NewReference => $new_value_id,
2201 ReferenceType => 'RT::ObjectCustomFieldValue',
2204 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
2207 return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
2213 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
2215 Deletes VALUE as a value of CustomField FIELD.
2217 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
2219 If VALUE is not a valid value for the custom field, returns
2220 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
2224 sub DeleteCustomFieldValue {
2233 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2234 unless ( $cf->Id ) {
2235 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2238 my ( $val, $msg ) = $cf->DeleteValueForObject(
2240 Id => $args{'ValueId'},
2241 Content => $args{'Value'},
2247 my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
2248 Type => 'CustomField',
2250 OldReference => $val,
2251 ReferenceType => 'RT::ObjectCustomFieldValue',
2253 unless ($TransactionId) {
2254 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
2257 my $old_value = $TransactionObj->OldValue;
2258 # For datetime, we need to display them in "human" format in result message
2259 if ( $cf->Type eq 'DateTime' ) {
2260 my $DateObj = RT::Date->new( $self->CurrentUser );
2263 Value => $old_value,
2265 $old_value = $DateObj->AsString;
2270 "[_1] is no longer a value for custom field [_2]",
2271 $old_value, $cf->Name
2278 =head2 FirstCustomFieldValue FIELD
2280 Return the content of the first value of CustomField FIELD for this ticket
2281 Takes a field id or name
2285 sub FirstCustomFieldValue {
2289 my $values = $self->CustomFieldValues( $field );
2290 return undef unless my $first = $values->First;
2291 return $first->Content;
2294 =head2 CustomFieldValuesAsString FIELD
2296 Return the content of the CustomField FIELD for this ticket.
2297 If this is a multi-value custom field, values will be joined with newlines.
2299 Takes a field id or name as the first argument
2301 Takes an optional Separator => "," second and third argument
2302 if you want to join the values using something other than a newline
2306 sub CustomFieldValuesAsString {
2310 my $separator = $args{Separator} || "\n";
2312 my $values = $self->CustomFieldValues( $field );
2313 return join ($separator, grep { defined $_ }
2314 map { $_->Content } @{$values->ItemsArrayRef});
2319 =head2 CustomFieldValues FIELD
2321 Return a ObjectCustomFieldValues object of all values of the CustomField whose
2322 id or Name is FIELD for this record.
2324 Returns an RT::ObjectCustomFieldValues object
2328 sub CustomFieldValues {
2333 my $cf = $self->LoadCustomFieldByIdentifier( $field );
2335 # we were asked to search on a custom field we couldn't find
2336 unless ( $cf->id ) {
2337 $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2338 return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2340 return ( $cf->ValuesForObject($self) );
2343 # we're not limiting to a specific custom field;
2344 my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2345 $ocfs->LimitToObject( $self );
2349 =head2 LoadCustomFieldByIdentifier IDENTIFER
2351 Find the custom field has id or name IDENTIFIER for this object.
2353 If no valid field is found, returns an empty RT::CustomField object.
2357 sub LoadCustomFieldByIdentifier {
2362 if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2363 $cf = RT::CustomField->new($self->CurrentUser);
2364 $cf->SetContextObject( $self );
2365 $cf->LoadById( $field->id );
2367 elsif ($field =~ /^\d+$/) {
2368 $cf = RT::CustomField->new($self->CurrentUser);
2369 $cf->SetContextObject( $self );
2370 $cf->LoadById($field);
2373 my $cfs = $self->CustomFields($self->CurrentUser);
2374 $cfs->SetContextObject( $self );
2375 $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2376 $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2381 sub ACLEquivalenceObjects { }
2385 Takes a paramhash with the attributes 'Right' and 'Principal'
2386 'Right' is a ticket-scoped textual right from RT::ACE
2387 'Principal' is an RT::User object
2389 Returns 1 if the principal has the right. Returns undef if not.
2401 $args{Principal} ||= $self->CurrentUser->PrincipalObj;
2403 return $args{'Principal'}->HasRight(
2404 Object => $self->Id ? $self : $RT::System,
2405 Right => $args{'Right'}
2409 sub CurrentUserHasRight {
2411 return $self->HasRight( Right => @_ );
2414 sub ModifyLinkRight { }
2416 =head2 ColumnMapClassName
2418 ColumnMap needs a massaged collection class name to load the correct list
2419 display. Equivalent to L<RT::SearchBuilder/ColumnMapClassName>, but provided
2420 for a record instead of a collection.
2422 Returns a string. May be called as a package method.
2426 sub ColumnMapClassName {
2428 my $Class = ref($self) || $self;
2433 sub BasicColumns { }
2436 return RT->Config->Get('WebPath'). "/index.html?q=";
2441 return undef unless defined $self->Id;
2442 return "@{[ref $self]}-$RT::Organization-@{[$self->Id]}";
2445 sub FindDependencies {
2447 my ($walker, $deps) = @_;
2448 for my $col (qw/Creator LastUpdatedBy/) {
2449 if ( $self->_Accessible( $col, 'read' ) ) {
2450 next unless $self->$col;
2451 my $obj = RT::Principal->new( $self->CurrentUser );
2452 $obj->Load( $self->$col );
2453 $deps->Add( out => $obj->Object );
2457 # Object attributes, we have to check on every object
2458 my $objs = $self->Attributes;
2459 $deps->Add( in => $objs );
2462 if ( $self->isa("RT::Ticket")
2463 or $self->isa("RT::User")
2464 or $self->isa("RT::Group")
2465 or $self->isa("RT::Article")
2466 or $self->isa("RT::Queue") )
2468 $objs = RT::Transactions->new( $self->CurrentUser );
2469 $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2470 $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2471 $deps->Add( in => $objs );
2474 # Object custom field values
2475 if (( $self->isa("RT::Transaction")
2476 or $self->isa("RT::Ticket")
2477 or $self->isa("RT::User")
2478 or $self->isa("RT::Group")
2479 or $self->isa("RT::Queue")
2480 or $self->isa("RT::Article") )
2481 and $self->can("CustomFieldValues") )
2483 $objs = $self->CustomFieldValues; # Actually OCFVs
2484 $objs->{find_expired_rows} = 1;
2485 $deps->Add( in => $objs );
2489 if ( $self->isa("RT::Group")
2490 or $self->isa("RT::Class")
2491 or $self->isa("RT::Queue")
2492 or $self->isa("RT::CustomField") )
2494 $objs = RT::ACL->new( $self->CurrentUser );
2495 $objs->LimitToObject( $self );
2496 $deps->Add( in => $objs );
2508 Creator => "CreatorObj",
2509 LastUpdatedBy => "LastUpdatedByObj",
2510 %{ $args{Methods} || {} },
2513 my %values = %{$self->{values}};
2515 my %ca = %{ $self->_ClassAccessible };
2516 my @cols = grep {exists $values{lc $_} and defined $values{lc $_}} keys %ca;
2519 $store{$_} = $values{lc $_} for @cols;
2520 $store{id} = $values{id}; # Explicitly necessary in some cases
2522 # Un-apply the _transfer_ encoding, but don't mess with the octets
2523 # themselves. Calling ->Content directly would, in some cases,
2524 # decode from some mostly-unknown character set -- which reversing
2525 # on the far end would be complicated.
2526 if ($ca{ContentEncoding} and $ca{ContentType}) {
2527 my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2528 $store{$content_col} = $self->_DecodeLOB(
2529 "application/octet-stream", # Lie so that we get bytes, not characters
2530 $self->ContentEncoding,
2531 $self->_Value( $content_col, decode_utf8 => 0 )
2533 delete $store{ContentEncoding};
2535 return %store unless $args{UIDs};
2537 # Use FooObj to turn Foo into a reference to the UID
2538 for my $col ( grep {$store{$_}} @cols ) {
2539 my $method = $methods{$col};
2542 $method =~ s/(Id)?$/Obj/;
2544 next unless $self->can($method);
2546 my $obj = $self->$method;
2547 next unless $obj and $obj->isa("RT::Record");
2548 $store{$col} = \($obj->UID);
2551 # Anything on an object should get the UID stored instead
2552 if ($store{ObjectType} and $store{ObjectId} and $self->can("Object")) {
2553 delete $store{$_} for qw/ObjectType ObjectId/;
2554 $store{Object} = \($self->Object->UID);
2562 my ($importer, $uid, $data) = @_;
2564 my $ca = $class->_ClassAccessible;
2567 if ($ca{ContentEncoding} and $ca{ContentType}) {
2568 my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2569 if (defined $data->{$content_col}) {
2570 my ($ContentEncoding, $Content) = $class->_EncodeLOB(
2571 $data->{$content_col}, $data->{ContentType},
2573 $data->{ContentEncoding} = $ContentEncoding;
2574 $data->{$content_col} = $Content;
2578 if ($data->{Object} and not $ca{Object}) {
2579 my $ref_uid = ${ delete $data->{Object} };
2580 my $ref = $importer->Lookup( $ref_uid );
2582 my ($class, $id) = @{$ref};
2583 $data->{ObjectId} = $id;
2584 $data->{ObjectType} = $class;
2586 $data->{ObjectId} = 0;
2587 $data->{ObjectType} = "";
2588 $importer->Postpone(
2591 column => "ObjectId",
2592 classcolumn => "ObjectType",
2597 for my $col (keys %{$data}) {
2598 if (ref $data->{$col}) {
2599 my $ref_uid = ${ $data->{$col} };
2600 my $ref = $importer->Lookup( $ref_uid );
2602 my (undef, $id) = @{$ref};
2603 $data->{$col} = $id;
2606 $importer->Postpone(
2621 =head2 _AsInsertQuery
2623 Returns INSERT query string that duplicates current record and
2624 can be used to insert record back into DB after delete.
2632 my $dbh = $RT::Handle->dbh;
2634 my $res = "INSERT INTO ". $dbh->quote_identifier( $self->Table );
2635 my $values = $self->{'values'};
2636 $res .= "(". join( ",", map { $dbh->quote_identifier( $_ ) } sort keys %$values ) .")";
2638 $res .= "(". join( ",", map { $dbh->quote( $values->{$_} ) } sort keys %$values ) .")";
2644 sub BeforeWipeout { return 1 }
2648 Returns L<RT::Shredder::Dependencies> object.
2657 Flags => RT::Shredder::Constants::DEPENDS_ON,
2661 unless( $self->id ) {
2662 RT::Shredder::Exception->throw('Object is not loaded');
2665 my $deps = RT::Shredder::Dependencies->new();
2666 if( $args{'Flags'} & RT::Shredder::Constants::DEPENDS_ON ) {
2667 $self->__DependsOn( %args, Dependencies => $deps );
2677 Dependencies => undef,
2680 my $deps = $args{'Dependencies'};
2683 # Object custom field values
2684 my $objs = $self->CustomFieldValues;
2685 $objs->{'find_expired_rows'} = 1;
2686 push( @$list, $objs );
2689 $objs = $self->Attributes;
2690 push( @$list, $objs );
2693 $objs = RT::Transactions->new( $self->CurrentUser );
2694 $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2695 $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2696 push( @$list, $objs );
2699 if ( $self->can('Links') ) {
2700 # make sure we don't skip any record
2701 no warnings 'redefine';
2702 local *RT::Links::IsValidLink = sub { 1 };
2704 foreach ( qw(Base Target) ) {
2705 my $objs = $self->Links( $_ );
2707 push @$list, $objs->ItemsArrayRef;
2712 $objs = RT::ACL->new( $self->CurrentUser );
2713 $objs->LimitToObject( $self );
2714 push( @$list, $objs );
2716 $deps->_PushDependencies(
2717 BaseObject => $self,
2718 Flags => RT::Shredder::Constants::DEPENDS_ON,
2719 TargetObjects => $list,
2720 Shredder => $args{'Shredder'}
2725 # implement proxy method because some RT classes
2726 # override Delete method
2730 my $msg = $self->UID ." wiped out";
2731 $self->SUPER::Delete;
2732 $RT::Logger->info( $msg );
2736 RT::Base->_ImportOverlays();