1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2014 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
75 our $_TABLE_ATTR = { };
76 use base RT->Config->Get('RecordBaseClass');
82 $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
83 $self->CurrentUser(@_);
90 The primary keys for RT classes is 'id'
94 sub _PrimaryKeys { return ['id'] }
95 # short circuit many, many thousands of calls from searchbuilder
96 sub _PrimaryKey { 'id' }
100 Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do
101 on a very common codepath
103 C<id> is an alias to C<Id> and is the preferred way to call this method.
108 return shift->{'values'}->{id};
115 Delete this record object from the database.
121 my ($rv) = $self->SUPER::Delete;
123 return ($rv, $self->loc("Object deleted"));
126 return(0, $self->loc("Object could not be deleted"))
132 Returns a string which is this object's type. The type is the class,
133 without the "RT::" prefix.
140 if (ref($self) =~ /^.*::(\w+)$/) {
141 return $self->loc($1);
143 return $self->loc(ref($self));
149 Return this object's attributes as an RT::Attributes object
155 unless ($self->{'attributes'}) {
156 $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
157 $self->{'attributes'}->LimitToObject($self);
158 $self->{'attributes'}->OrderByCols({FIELD => 'id'});
160 return ($self->{'attributes'});
164 =head2 AddAttribute { Name, Description, Content }
166 Adds a new attribute for this object.
172 my %args = ( Name => undef,
173 Description => undef,
177 my $attr = RT::Attribute->new( $self->CurrentUser );
178 my ( $id, $msg ) = $attr->Create(
180 Name => $args{'Name'},
181 Description => $args{'Description'},
182 Content => $args{'Content'} );
185 # XXX TODO: Why won't RedoSearch work here?
186 $self->Attributes->_DoSearch;
192 =head2 SetAttribute { Name, Description, Content }
194 Like AddAttribute, but replaces all existing attributes with the same Name.
200 my %args = ( Name => undef,
201 Description => undef,
205 my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
206 or return $self->AddAttribute( %args );
208 my $AttributeObj = pop( @AttributeObjs );
209 $_->Delete foreach @AttributeObjs;
211 $AttributeObj->SetDescription( $args{'Description'} );
212 $AttributeObj->SetContent( $args{'Content'} );
214 $self->Attributes->RedoSearch;
218 =head2 DeleteAttribute NAME
220 Deletes all attributes with the matching name for this object.
224 sub DeleteAttribute {
227 my ($val,$msg) = $self->Attributes->DeleteEntry( Name => $name );
228 $self->ClearAttributes;
232 =head2 FirstAttribute NAME
234 Returns the first attribute with the matching name for this object (as an
235 L<RT::Attribute> object), or C<undef> if no such attributes exist.
236 If there is more than one attribute with the matching name on the
237 object, the first value that was set is returned.
244 return ($self->Attributes->Named( $name ))[0];
248 sub ClearAttributes {
250 delete $self->{'attributes'};
254 sub _Handle { return $RT::Handle }
258 =head2 Create PARAMHASH
260 Takes a PARAMHASH of Column -> Value pairs.
261 If any Column has a Validate$PARAMNAME subroutine defined and the
262 value provided doesn't pass validation, this routine returns
265 If this object's table has any of the following atetributes defined as
266 'Auto', this routine will automatically fill in their values.
285 foreach my $key ( keys %attribs ) {
286 if (my $method = $self->can("Validate$key")) {
287 if (! $method->( $self, $attribs{$key} ) ) {
289 return ( 0, $self->loc('Invalid value for [_1]', $key) );
300 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime();
303 sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec);
305 $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
307 if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
308 $attribs{'Creator'} = $self->CurrentUser->id || '0';
310 $attribs{'LastUpdated'} = $now_iso
311 if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
313 $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
314 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
316 my $id = $self->SUPER::Create(%attribs);
317 if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
321 $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
328 # If the object was created in the database,
329 # load it up now, so we're sure we get what the database
330 # has. Arguably, this should not be necessary, but there
331 # isn't much we can do about it.
335 return ( $id, $self->loc('Object could not be created') );
343 if (UNIVERSAL::isa('errno',$id)) {
347 $self->Load($id) if ($id);
352 return ( $id, $self->loc('Object created') );
364 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
372 # We don't want to hang onto this
373 $self->ClearAttributes;
375 return $self->SUPER::LoadByCols( @_ ) unless $self->_Handle->CaseSensitive;
377 # If this database is case sensitive we need to uncase objects for
380 foreach my $key ( keys %hash ) {
382 # If we've been passed an empty value, we can't do the lookup.
383 # We don't need to explicitly downcase integers or an id.
384 if ( $key ne 'id' && defined $hash{ $key } && $hash{ $key } !~ /^\d+$/ ) {
385 my ($op, $val, $func);
386 ($key, $op, $val, $func) =
387 $self->_Handle->_MakeClauseCaseInsensitive( $key, '=', delete $hash{ $key } );
388 $hash{$key}->{operator} = $op;
389 $hash{$key}->{value} = $val;
390 $hash{$key}->{function} = $func;
393 return $self->SUPER::LoadByCols( %hash );
398 # There is room for optimizations in most of those subs:
403 my $obj = RT::Date->new( $self->CurrentUser );
405 $obj->Set( Format => 'sql', Value => $self->LastUpdated );
413 my $obj = RT::Date->new( $self->CurrentUser );
415 $obj->Set( Format => 'sql', Value => $self->Created );
422 # TODO: This should be deprecated
426 return ( $self->CreatedObj->AgeAsString() );
431 # TODO this should be deprecated
433 sub LastUpdatedAsString {
435 if ( $self->LastUpdated ) {
436 return ( $self->LastUpdatedObj->AsString() );
446 # TODO This should be deprecated
448 sub CreatedAsString {
450 return ( $self->CreatedObj->AsString() );
455 # TODO This should be deprecated
457 sub LongSinceUpdateAsString {
459 if ( $self->LastUpdated ) {
461 return ( $self->LastUpdatedObj->AgeAsString() );
482 #if the user is trying to modify the record
483 # TODO: document _why_ this code is here
485 if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
489 my $old_val = $self->__Value($args{'Field'});
490 $self->_SetLastUpdated();
491 my $ret = $self->SUPER::_Set(
492 Field => $args{'Field'},
493 Value => $args{'Value'},
494 IsSQL => $args{'IsSQL'}
496 my ($status, $msg) = $ret->as_array();
498 # @values has two values, a status code and a message.
500 # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
501 # we want to change the standard "success" message
503 if ($self->SQLType( $args{'Field'}) =~ /text/) {
506 $self->loc( $args{'Field'} ),
510 "[_1] changed from [_2] to [_3]",
511 $self->loc( $args{'Field'} ),
512 ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ),
513 '"' . $self->__Value( $args{'Field'}) . '"',
517 $msg = $self->CurrentUser->loc_fuzzy($msg);
520 return wantarray ? ($status, $msg) : $ret;
525 =head2 _SetLastUpdated
527 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
528 It takes no options. Arguably, this is a bug
532 sub _SetLastUpdated {
535 my $now = RT::Date->new( $self->CurrentUser );
538 if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
539 my ( $msg, $val ) = $self->__Set(
540 Field => 'LastUpdated',
544 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
545 my ( $msg, $val ) = $self->__Set(
546 Field => 'LastUpdatedBy',
547 Value => $self->CurrentUser->id
556 Returns an RT::User object with the RT account of the creator of this row
562 unless ( exists $self->{'CreatorObj'} ) {
564 $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
565 $self->{'CreatorObj'}->Load( $self->Creator );
567 return ( $self->{'CreatorObj'} );
572 =head2 LastUpdatedByObj
574 Returns an RT::User object of the last user to touch this object
578 sub LastUpdatedByObj {
580 unless ( exists $self->{LastUpdatedByObj} ) {
581 $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
582 $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
584 return $self->{'LastUpdatedByObj'};
591 Returns this record's URI
597 my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
598 return($uri->URIForObject($self));
602 =head2 ValidateName NAME
604 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
611 if (defined $value && $value=~ /^\d+$/) {
620 =head2 SQLType attribute
622 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
630 return ($self->_Accessible($field, 'type'));
638 my %args = ( decode_utf8 => 1, @_ );
641 $RT::Logger->error("__Value called with undef field");
644 my $value = $self->SUPER::__Value($field);
646 return undef if (!defined $value);
648 # Pg returns character columns as character strings; mysql and
649 # sqlite return them as bytes. While mysql can be made to return
650 # characters, using the mysql_enable_utf8 flag, the "Content" column
651 # is bytes on mysql and characters on Postgres, making true
652 # consistency impossible.
653 if ( $args{'decode_utf8'} ) {
654 if ( !utf8::is_utf8($value) ) { # mysql/sqlite
655 utf8::decode($value);
658 if ( utf8::is_utf8($value) ) {
659 utf8::encode($value);
667 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
672 'cache_for_sec' => 30,
678 sub _BuildTableAttributes {
680 my $class = ref($self) || $self;
683 if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
684 $attributes = $self->_CoreAccessible();
685 } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
686 $attributes = $self->_ClassAccessible();
690 foreach my $column (keys %$attributes) {
691 foreach my $attr ( keys %{ $attributes->{$column} } ) {
692 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
695 foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
696 next unless UNIVERSAL::can( $self, $method );
697 $attributes = $self->$method();
699 foreach my $column ( keys %$attributes ) {
700 foreach my $attr ( keys %{ $attributes->{$column} } ) {
701 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
708 =head2 _ClassAccessible
710 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
711 DBIx::SearchBuilder::Record
715 sub _ClassAccessible {
717 return $_TABLE_ATTR->{ref($self) || $self};
720 =head2 _Accessible COLUMN ATTRIBUTE
722 returns the value of ATTRIBUTE for COLUMN
730 my $attribute = lc(shift);
731 return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
732 return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
736 =head2 _EncodeLOB BODY MIME_TYPE FILENAME
738 Takes a potentially large attachment. Returns (ContentEncoding,
739 EncodedBody, MimeType, Filename) based on system configuration and
740 selected database. Returns a custom (short) text/plain message if
741 DropLongAttachments causes an attachment to not be stored.
743 Encodes your data as base64 or Quoted-Printable as needed based on your
744 Databases's restrictions and the UTF-8ness of the data being passed in. Since
745 we are storing in columns marked UTF8, we must ensure that binary data is
746 encoded on databases which are strict.
748 This function expects to receive an octet string in order to properly
749 evaluate and encode it. It will return an octet string.
756 my $MIMEType = shift || '';
757 my $Filename = shift;
759 my $ContentEncoding = 'none';
761 RT::Util::assert_bytes( $Body );
763 #get the max attachment length from RT
764 my $MaxSize = RT->Config->Get('MaxAttachmentSize');
766 #if the current attachment contains nulls and the
767 #database doesn't support embedded nulls
769 if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
771 # set a flag telling us to mimencode the attachment
772 $ContentEncoding = 'base64';
774 #cut the max attchment size by 25% (for mime-encoding overhead.
775 $RT::Logger->debug("Max size is $MaxSize");
776 $MaxSize = $MaxSize * 3 / 4;
777 # Some databases (postgres) can't handle non-utf8 data
778 } elsif ( !$RT::Handle->BinarySafeBLOBs
779 && $Body =~ /\P{ASCII}/
780 && !Encode::is_utf8( $Body, 1 ) ) {
781 $ContentEncoding = 'quoted-printable';
784 #if the attachment is larger than the maximum size
785 if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
787 # if we're supposed to truncate large attachments
788 if (RT->Config->Get('TruncateLongAttachments')) {
790 # truncate the attachment to that length.
791 $Body = substr( $Body, 0, $MaxSize );
795 # elsif we're supposed to drop large attachments on the floor,
796 elsif (RT->Config->Get('DropLongAttachments')) {
798 # drop the attachment on the floor
799 $RT::Logger->info( "$self: Dropped an attachment of size "
801 $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
802 $Filename .= ".txt" if $Filename;
803 return ("none", "Large attachment dropped", "text/plain", $Filename );
807 # if we need to mimencode the attachment
808 if ( $ContentEncoding eq 'base64' ) {
809 # base64 encode the attachment
810 $Body = MIME::Base64::encode_base64($Body);
812 } elsif ($ContentEncoding eq 'quoted-printable') {
813 $Body = MIME::QuotedPrint::encode($Body);
816 return ($ContentEncoding, $Body, $MIMEType, $Filename );
819 =head2 _DecodeLOB C<ContentType>, C<ContentEncoding>, C<Content>
821 Unpacks data stored in the database, which may be base64 or QP encoded
822 because of our need to store binary and badly encoded data in columns
823 marked as UTF-8. Databases such as PostgreSQL and Oracle care that you
824 are feeding them invalid UTF-8 and will refuse the content. This
825 function handles unpacking the encoded data.
827 It returns textual data as a UTF-8 string which has been processed by Encode's
828 PERLQQ filter which will replace the invalid bytes with \x{HH} so you can see
829 the invalid byte but won't run into problems treating the data as UTF-8 later.
831 This is similar to how we filter all data coming in via the web UI in
832 RT::Interface::Web::DecodeARGS. This filter should only end up being
833 applied to old data from less UTF-8-safe versions of RT.
835 If the passed C<ContentType> includes a character set, that will be used
836 to decode textual data; the default character set is UTF-8. This is
837 necessary because while we attempt to store textual data as UTF-8, the
838 definition of "textual" has migrated over time, and thus we may now need
839 to attempt to decode data that was previously not trancoded on insertion.
841 Important Note - This function expects an octet string and returns a
842 character string for non-binary data.
848 my $ContentType = shift || '';
849 my $ContentEncoding = shift || 'none';
852 RT::Util::assert_bytes( $Content );
854 if ( $ContentEncoding eq 'base64' ) {
855 $Content = MIME::Base64::decode_base64($Content);
857 elsif ( $ContentEncoding eq 'quoted-printable' ) {
858 $Content = MIME::QuotedPrint::decode($Content);
860 elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
861 return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
863 if ( RT::I18N::IsTextualContentType($ContentType) ) {
864 my $entity = MIME::Entity->new();
865 $entity->head->add("Content-Type", $ContentType);
866 $entity->bodyhandle( MIME::Body::Scalar->new( $Content ) );
867 my $charset = RT::I18N::_FindOrGuessCharset($entity);
868 $charset = 'utf-8' if not $charset or not Encode::find_encoding($charset);
870 $Content = Encode::decode($charset,$Content,Encode::FB_PERLQQ);
875 # A helper table for links mapping to make it easier
876 # to build and parse links between tickets
878 use vars '%LINKDIRMAP';
881 MemberOf => { Base => 'MemberOf',
882 Target => 'HasMember', },
883 RefersTo => { Base => 'RefersTo',
884 Target => 'ReferredToBy', },
885 DependsOn => { Base => 'DependsOn',
886 Target => 'DependedOnBy', },
887 MergedInto => { Base => 'MergedInto',
888 Target => 'MergedInto', },
892 =head2 Update ARGSHASH
894 Updates fields on an object for you using the proper Set methods,
895 skipping unchanged values.
897 ARGSRef => a hashref of attributes => value for the update
898 AttributesRef => an arrayref of keys in ARGSRef that should be updated
899 AttributePrefix => a prefix that should be added to the attributes in AttributesRef
900 when looking up values in ARGSRef
901 Bare attributes are tried before prefixed attributes
903 Returns a list of localized results of the update
912 AttributesRef => undef,
913 AttributePrefix => undef,
917 my $attributes = $args{'AttributesRef'};
918 my $ARGSRef = $args{'ARGSRef'};
921 # gather all new values
922 foreach my $attribute (@$attributes) {
924 if ( defined $ARGSRef->{$attribute} ) {
925 $value = $ARGSRef->{$attribute};
928 defined( $args{'AttributePrefix'} )
930 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
933 $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
940 $value =~ s/\r\n/\n/gs;
942 my $truncated_value = $self->TruncateValue($attribute, $value);
944 # If Queue is 'General', we want to resolve the queue name for
947 # This is in an eval block because $object might not exist.
948 # and might not have a Name method. But "can" won't find autoloaded
949 # items. If it fails, we don't care
951 no warnings "uninitialized";
954 my $object = $attribute . "Obj";
955 my $name = $self->$object->Name;
956 next if $name eq $value || $name eq ($value || 0);
959 my $current = $self->$attribute();
960 # RT::Queue->Lifecycle returns a Lifecycle object instead of name
961 $current = eval { $current->Name } if ref $current;
962 next if $truncated_value eq $current;
963 next if ( $truncated_value || 0 ) eq $current;
966 $new_values{$attribute} = $value;
969 return $self->_UpdateAttributes(
970 Attributes => $attributes,
971 NewValues => \%new_values,
975 sub _UpdateAttributes {
985 foreach my $attribute (@{ $args{Attributes} }) {
986 next if !exists($args{NewValues}{$attribute});
988 my $value = $args{NewValues}{$attribute};
989 my $method = "Set$attribute";
990 my ( $code, $msg ) = $self->$method($value);
991 my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
993 # Default to $id, but use name if we can get it.
994 my $label = $self->id;
995 $label = $self->Name if (UNIVERSAL::can($self,'Name'));
996 # this requires model names to be loc'ed.
1007 push @results, $self->loc( $prefix ) . " $label: ". $msg;
1011 "[_1] could not be set to [_2].", # loc
1012 "That is already the current value", # loc
1013 "No value sent to _Set!", # loc
1014 "Illegal value for [_1]", # loc
1015 "The new value has been set.", # loc
1016 "No column specified", # loc
1017 "Immutable field", # loc
1018 "Nonexistant field?", # loc
1019 "Invalid data", # loc
1020 "Couldn't find row", # loc
1021 "Missing a primary key?: [_1]", # loc
1022 "Found Object", # loc
1036 This returns an RT::Links object which references all the tickets
1037 which are 'MembersOf' this ticket
1043 return ( $self->_Links( 'Target', 'MemberOf' ) );
1050 This returns an RT::Links object which references all the tickets that this
1051 ticket is a 'MemberOf'
1057 return ( $self->_Links( 'Base', 'MemberOf' ) );
1064 This returns an RT::Links object which shows all references for which this ticket is a base
1070 return ( $self->_Links( 'Base', 'RefersTo' ) );
1077 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1083 return ( $self->_Links( 'Target', 'RefersTo' ) );
1090 This returns an RT::Links object which references all the tickets that depend on this one
1096 return ( $self->_Links( 'Target', 'DependsOn' ) );
1102 =head2 HasUnresolvedDependencies
1104 Takes a paramhash of Type (default to '__any'). Returns the number of
1105 unresolved dependencies, if $self->UnresolvedDependencies returns an
1106 object with one or more members of that type. Returns false
1111 sub HasUnresolvedDependencies {
1118 my $deps = $self->UnresolvedDependencies;
1121 $deps->Limit( FIELD => 'Type',
1123 VALUE => $args{Type});
1129 if ($deps->Count > 0) {
1130 return $deps->Count;
1139 =head2 UnresolvedDependencies
1141 Returns an RT::Tickets object of tickets which this ticket depends on
1142 and which have a status of new, open or stalled. (That list comes from
1143 RT::Queue->ActiveStatusArray
1148 sub UnresolvedDependencies {
1150 my $deps = RT::Tickets->new($self->CurrentUser);
1152 my @live_statuses = RT::Queue->ActiveStatusArray();
1153 foreach my $status (@live_statuses) {
1154 $deps->LimitStatus(VALUE => $status);
1156 $deps->LimitDependedOnBy($self->Id);
1164 =head2 AllDependedOnBy
1166 Returns an array of RT::Ticket objects which (directly or indirectly)
1167 depends on this ticket; takes an optional 'Type' argument in the param
1168 hash, which will limit returned tickets to that type, as well as cause
1169 tickets with that type to serve as 'leaf' nodes that stops the recursive
1174 sub AllDependedOnBy {
1176 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1177 Direction => 'Target', @_ );
1182 Returns an array of RT::Ticket objects which this ticket (directly or
1183 indirectly) depends on; takes an optional 'Type' argument in the param
1184 hash, which will limit returned tickets to that type, as well as cause
1185 tickets with that type to serve as 'leaf' nodes that stops the
1186 recursive dependency search.
1192 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1193 Direction => 'Base', @_ );
1196 sub _AllLinkedTickets {
1208 my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1209 while (my $link = $dep->Next()) {
1210 my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1211 next unless ($uri->IsLocal());
1212 my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1213 next if $args{_found}{$obj->Id};
1216 $args{_found}{$obj->Id} = $obj;
1217 $obj->_AllLinkedTickets( %args, _top => 0 );
1219 elsif ($obj->Type and $obj->Type eq $args{Type}) {
1220 $args{_found}{$obj->Id} = $obj;
1223 $obj->_AllLinkedTickets( %args, _top => 0 );
1228 return map { $args{_found}{$_} } sort keys %{$args{_found}};
1239 This returns an RT::Links object which references all the tickets that this ticket depends on
1245 return ( $self->_Links( 'Base', 'DependsOn' ) );
1254 This returns an RT::Links object which references all the customers that
1255 this object is a member of. This includes both explicitly linked customers
1256 and links implied by services.
1261 my( $self, %opt ) = @_;
1262 my $Debug = $opt{'Debug'};
1264 unless ( $self->{'Customers'} ) {
1266 $self->{'Customers'} = $self->MemberOf->Clone;
1268 for my $fstable (qw(cust_main cust_svc)) {
1270 $self->{'Customers'}->Limit(
1272 OPERATOR => 'STARTSWITH',
1273 VALUE => "freeside://freeside/$fstable",
1274 ENTRYAGGREGATOR => 'OR',
1275 SUBCLAUSE => 'customers',
1280 warn "->Customers method called on $self; returning ".
1281 ref($self->{'Customers'}). ' object'
1284 return $self->{'Customers'};
1293 This returns an RT::Links object which references all the services this
1294 object is a member of.
1299 my( $self, %opt ) = @_;
1301 unless ( $self->{'Services'} ) {
1303 $self->{'Services'} = $self->MemberOf->Clone;
1305 $self->{'Services'}->Limit(
1307 OPERATOR => 'STARTSWITH',
1308 VALUE => "freeside://freeside/cust_svc",
1312 return $self->{'Services'};
1320 =head2 Links DIRECTION [TYPE]
1322 Return links (L<RT::Links>) to/from this object.
1324 DIRECTION is either 'Base' or 'Target'.
1326 TYPE is a type of links to return, it can be omitted to get
1331 sub Links { shift->_Links(@_) }
1336 #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1339 my $type = shift || "";
1341 unless ( $self->{"$field$type"} ) {
1342 $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1343 # at least to myself
1344 $self->{"$field$type"}->Limit( FIELD => $field,
1345 VALUE => $self->URI,
1346 ENTRYAGGREGATOR => 'OR' );
1347 $self->{"$field$type"}->Limit( FIELD => 'Type',
1351 return ( $self->{"$field$type"} );
1359 Takes a Type and returns a string that is more human readable.
1365 my %args = ( Type => '',
1368 $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1369 $args{Type} =~ s/^\s+//;
1378 Takes either a Target or a Base and returns a string of human friendly text.
1384 my %args = ( Object => undef,
1388 my $text = "URI " . $args{FallBack};
1389 if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1390 $text = "Ticket " . $args{Object}->id;
1399 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1401 Returns C<link id>, C<message> and C<exist> flag.
1408 my %args = ( Target => '',
1415 # Remote_link is the URI of the object that is not this ticket
1419 if ( $args{'Base'} and $args{'Target'} ) {
1420 $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1421 return ( 0, $self->loc("Can't specify both base and target") );
1423 elsif ( $args{'Base'} ) {
1424 $args{'Target'} = $self->URI();
1425 $remote_link = $args{'Base'};
1426 $direction = 'Target';
1428 elsif ( $args{'Target'} ) {
1429 $args{'Base'} = $self->URI();
1430 $remote_link = $args{'Target'};
1431 $direction = 'Base';
1434 return ( 0, $self->loc('Either base or target must be specified') );
1437 # Check if the link already exists - we don't want duplicates
1439 my $old_link = RT::Link->new( $self->CurrentUser );
1440 $old_link->LoadByParams( Base => $args{'Base'},
1441 Type => $args{'Type'},
1442 Target => $args{'Target'} );
1443 if ( $old_link->Id ) {
1444 $RT::Logger->debug("$self Somebody tried to duplicate a link");
1445 return ( $old_link->id, $self->loc("Link already exists"), 1 );
1451 # Storing the link in the DB.
1452 my $link = RT::Link->new( $self->CurrentUser );
1453 my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1454 Base => $args{Base},
1455 Type => $args{Type} );
1458 $RT::Logger->error("Link could not be created: ".$linkmsg);
1459 return ( 0, $self->loc("Link could not be created") );
1462 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1463 FallBack => $args{Base});
1464 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1465 FallBack => $args{Target});
1466 my $typetext = $self->FormatType(Type => $args{Type});
1468 "$basetext $typetext $targettext.";
1469 return ( $linkid, $TransString ) ;
1476 Delete a link. takes a paramhash of Base, Target and Type.
1477 Either Base or Target must be null. The null value will
1478 be replaced with this ticket's id
1491 #we want one of base and target. we don't care which
1492 #but we only want _one_
1497 if ( $args{'Base'} and $args{'Target'} ) {
1498 $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1499 return ( 0, $self->loc("Can't specify both base and target") );
1501 elsif ( $args{'Base'} ) {
1502 $args{'Target'} = $self->URI();
1503 $remote_link = $args{'Base'};
1504 $direction = 'Target';
1506 elsif ( $args{'Target'} ) {
1507 $args{'Base'} = $self->URI();
1508 $remote_link = $args{'Target'};
1512 $RT::Logger->error("Base or Target must be specified");
1513 return ( 0, $self->loc('Either base or target must be specified') );
1516 my $link = RT::Link->new( $self->CurrentUser );
1517 $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} );
1520 $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=> $args{'Target'} );
1524 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1525 FallBack => $args{Base});
1526 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1527 FallBack => $args{Target});
1528 my $typetext = $self->FormatType(Type => $args{Type});
1529 my $linkid = $link->id;
1531 my $TransString = "$basetext no longer $typetext $targettext.";
1532 return ( 1, $TransString);
1535 #if it's not a link we can find
1537 $RT::Logger->debug("Couldn't find that link");
1538 return ( 0, $self->loc("Link not found") );
1543 =head1 LockForUpdate
1545 In a database transaction, gains an exclusive lock on the row, to
1546 prevent race conditions. On SQLite, this is a "RESERVED" lock on the
1554 my $pk = $self->_PrimaryKey;
1555 my $id = @_ ? $_[0] : $self->$pk;
1556 $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1557 if (RT->Config->Get('DatabaseType') eq "SQLite") {
1558 # SQLite does DB-level locking, upgrading the transaction to
1559 # "RESERVED" on the first UPDATE/INSERT/DELETE. Do a no-op
1560 # UPDATE to force the upgade.
1561 return RT->DatabaseHandle->dbh->do(
1562 "UPDATE " .$self->Table.
1563 " SET $pk = $pk WHERE 1 = 0");
1565 return $self->_LoadFromSQL(
1566 "SELECT * FROM ".$self->Table
1567 ." WHERE $pk = ? FOR UPDATE",
1573 =head2 _NewTransaction PARAMHASH
1575 Private function to create a new RT::Transaction object for this ticket update
1579 sub _NewTransaction {
1586 OldReference => undef,
1587 NewReference => undef,
1588 ReferenceType => undef,
1592 ActivateScrips => 1,
1594 SquelchMailTo => undef,
1599 my $in_txn = RT->DatabaseHandle->TransactionDepth;
1600 RT->DatabaseHandle->BeginTransaction unless $in_txn;
1602 $self->LockForUpdate;
1604 my $old_ref = $args{'OldReference'};
1605 my $new_ref = $args{'NewReference'};
1606 my $ref_type = $args{'ReferenceType'};
1607 if ($old_ref or $new_ref) {
1608 $ref_type ||= ref($old_ref) || ref($new_ref);
1610 $RT::Logger->error("Reference type not specified for transaction");
1613 $old_ref = $old_ref->Id if ref($old_ref);
1614 $new_ref = $new_ref->Id if ref($new_ref);
1617 require RT::Transaction;
1618 my $trans = RT::Transaction->new( $self->CurrentUser );
1619 my ( $transaction, $msg ) = $trans->Create(
1620 ObjectId => $self->Id,
1621 ObjectType => ref($self),
1622 TimeTaken => $args{'TimeTaken'},
1623 Type => $args{'Type'},
1624 Data => $args{'Data'},
1625 Field => $args{'Field'},
1626 NewValue => $args{'NewValue'},
1627 OldValue => $args{'OldValue'},
1628 NewReference => $new_ref,
1629 OldReference => $old_ref,
1630 ReferenceType => $ref_type,
1631 MIMEObj => $args{'MIMEObj'},
1632 ActivateScrips => $args{'ActivateScrips'},
1633 CommitScrips => $args{'CommitScrips'},
1634 SquelchMailTo => $args{'SquelchMailTo'},
1635 CustomFields => $args{'CustomFields'},
1638 # Rationalize the object since we may have done things to it during the caching.
1639 $self->Load($self->Id);
1641 $RT::Logger->warning($msg) unless $transaction;
1643 $self->_SetLastUpdated;
1645 if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1646 $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1648 if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1649 push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1652 RT->DatabaseHandle->Commit unless $in_txn;
1654 return ( $transaction, $msg, $trans );
1661 Returns an RT::Transactions object of all transactions on this record object
1668 use RT::Transactions;
1669 my $transactions = RT::Transactions->new( $self->CurrentUser );
1671 #If the user has no rights, return an empty object
1672 $transactions->Limit(
1673 FIELD => 'ObjectId',
1676 $transactions->Limit(
1677 FIELD => 'ObjectType',
1678 VALUE => ref($self),
1681 return ($transactions);
1688 my $cfs = RT::CustomFields->new( $self->CurrentUser );
1690 $cfs->SetContextObject( $self );
1691 # XXX handle multiple types properly
1692 $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1693 $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1694 $cfs->ApplySortOrder;
1699 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1700 # example, for RT::IR::Foo classes.
1702 sub CustomFieldLookupId {
1704 my $lookup = shift || $self->CustomFieldLookupType;
1705 my @classes = ($lookup =~ /RT::(\w+)-/g);
1707 # Work on "RT::Queue", for instance
1708 return $self->Id unless @classes;
1711 # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1712 my $final = shift @classes;
1713 foreach my $class (reverse @classes) {
1714 my $method = "${class}Obj";
1715 $object = $object->$method;
1718 my $id = $object->$final;
1719 unless (defined $id) {
1720 my $method = "${final}Obj";
1721 $id = $object->$method->Id;
1727 =head2 CustomFieldLookupType
1729 Returns the path RT uses to figure out which custom fields apply to this object.
1733 sub CustomFieldLookupType {
1735 return ref($self) || $self;
1739 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1741 VALUE should be a string. FIELD can be any identifier of a CustomField
1742 supported by L</LoadCustomFieldByIdentifier> method.
1744 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
1745 deletes the old value.
1746 If VALUE is not a valid value for the custom field, returns
1747 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
1748 $id is ID of created L<ObjectCustomFieldValue> object.
1752 sub AddCustomFieldValue {
1754 $self->_AddCustomFieldValue(@_);
1757 sub _AddCustomFieldValue {
1762 LargeContent => undef,
1763 ContentType => undef,
1764 RecordTransaction => 1,
1768 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1769 unless ( $cf->Id ) {
1770 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1773 my $OCFs = $self->CustomFields;
1774 $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1775 unless ( $OCFs->Count ) {
1779 "Custom field [_1] does not apply to this object",
1780 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
1785 # empty string is not correct value of any CF, so undef it
1786 foreach ( qw(Value LargeContent) ) {
1787 $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
1790 unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1791 return ( 0, $self->loc("Invalid value for custom field") );
1794 # If the custom field only accepts a certain # of values, delete the existing
1795 # value and record a "changed from foo to bar" transaction
1796 unless ( $cf->UnlimitedValues ) {
1798 # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1799 my $values = $cf->ValuesForObject($self);
1801 # We need to whack any old values here. In most cases, the custom field should
1802 # only have one value to delete. In the pathalogical case, this custom field
1803 # used to be a multiple and we have many values to whack....
1804 my $cf_values = $values->Count;
1806 if ( $cf_values > $cf->MaxValues ) {
1807 my $i = 0; #We want to delete all but the max we can currently have , so we can then
1808 # execute the same code to "change" the value from old to new
1809 while ( my $value = $values->Next ) {
1811 if ( $i < $cf_values ) {
1812 my ( $val, $msg ) = $cf->DeleteValueForObject(
1819 my ( $TransactionId, $Msg, $TransactionObj ) =
1820 $self->_NewTransaction(
1821 Type => 'CustomField',
1823 OldReference => $value,
1827 $values->RedoSearch if $i; # redo search if have deleted at least one value
1830 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
1834 my $old_value = $values->First;
1836 $old_content = $old_value->Content if $old_value;
1838 my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1840 Content => $args{'Value'},
1841 LargeContent => $args{'LargeContent'},
1842 ContentType => $args{'ContentType'},
1845 unless ( $new_value_id ) {
1846 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
1849 my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1850 $new_value->Load( $new_value_id );
1852 # now that adding the new value was successful, delete the old one
1854 my ( $val, $msg ) = $old_value->Delete();
1855 return ( 0, $msg ) unless $val;
1858 if ( $args{'RecordTransaction'} ) {
1859 my ( $TransactionId, $Msg, $TransactionObj ) =
1860 $self->_NewTransaction(
1861 Type => 'CustomField',
1863 OldReference => $old_value,
1864 NewReference => $new_value,
1868 my $new_content = $new_value->Content;
1870 # For datetime, we need to display them in "human" format in result message
1871 #XXX TODO how about date without time?
1872 if ($cf->Type eq 'DateTime') {
1873 my $DateObj = RT::Date->new( $self->CurrentUser );
1876 Value => $new_content,
1878 $new_content = $DateObj->AsString;
1880 if ( defined $old_content && length $old_content ) {
1883 Value => $old_content,
1885 $old_content = $DateObj->AsString;
1889 unless ( defined $old_content && length $old_content ) {
1890 return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
1892 elsif ( !defined $new_content || !length $new_content ) {
1893 return ( $new_value_id,
1894 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
1897 return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
1902 # otherwise, just add a new value and record "new value added"
1904 if ( !$cf->Repeated ) {
1905 my $values = $cf->ValuesForObject($self);
1906 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
1911 my ($new_value_id, $msg) = $cf->AddValueForObject(
1913 Content => $args{'Value'},
1914 LargeContent => $args{'LargeContent'},
1915 ContentType => $args{'ContentType'},
1918 unless ( $new_value_id ) {
1919 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
1921 if ( $args{'RecordTransaction'} ) {
1922 my ( $tid, $msg ) = $self->_NewTransaction(
1923 Type => 'CustomField',
1925 NewReference => $new_value_id,
1926 ReferenceType => 'RT::ObjectCustomFieldValue',
1929 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
1932 return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
1938 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1940 Deletes VALUE as a value of CustomField FIELD.
1942 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1944 If VALUE is not a valid value for the custom field, returns
1945 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1949 sub DeleteCustomFieldValue {
1958 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1959 unless ( $cf->Id ) {
1960 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1963 my ( $val, $msg ) = $cf->DeleteValueForObject(
1965 Id => $args{'ValueId'},
1966 Content => $args{'Value'},
1972 my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1973 Type => 'CustomField',
1975 OldReference => $val,
1976 ReferenceType => 'RT::ObjectCustomFieldValue',
1978 unless ($TransactionId) {
1979 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1982 my $old_value = $TransactionObj->OldValue;
1983 # For datetime, we need to display them in "human" format in result message
1984 if ( $cf->Type eq 'DateTime' ) {
1985 my $DateObj = RT::Date->new( $self->CurrentUser );
1988 Value => $old_value,
1990 $old_value = $DateObj->AsString;
1995 "[_1] is no longer a value for custom field [_2]",
1996 $old_value, $cf->Name
2003 =head2 FirstCustomFieldValue FIELD
2005 Return the content of the first value of CustomField FIELD for this ticket
2006 Takes a field id or name
2010 sub FirstCustomFieldValue {
2014 my $values = $self->CustomFieldValues( $field );
2015 return undef unless my $first = $values->First;
2016 return $first->Content;
2019 =head2 CustomFieldValuesAsString FIELD
2021 Return the content of the CustomField FIELD for this ticket.
2022 If this is a multi-value custom field, values will be joined with newlines.
2024 Takes a field id or name as the first argument
2026 Takes an optional Separator => "," second and third argument
2027 if you want to join the values using something other than a newline
2031 sub CustomFieldValuesAsString {
2035 my $separator = $args{Separator} || "\n";
2037 my $values = $self->CustomFieldValues( $field );
2038 return join ($separator, grep { defined $_ }
2039 map { $_->Content } @{$values->ItemsArrayRef});
2044 =head2 CustomFieldValues FIELD
2046 Return a ObjectCustomFieldValues object of all values of the CustomField whose
2047 id or Name is FIELD for this record.
2049 Returns an RT::ObjectCustomFieldValues object
2053 sub CustomFieldValues {
2058 my $cf = $self->LoadCustomFieldByIdentifier( $field );
2060 # we were asked to search on a custom field we couldn't find
2061 unless ( $cf->id ) {
2062 $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2063 return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2065 return ( $cf->ValuesForObject($self) );
2068 # we're not limiting to a specific custom field;
2069 my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2070 $ocfs->LimitToObject( $self );
2074 =head2 LoadCustomFieldByIdentifier IDENTIFER
2076 Find the custom field has id or name IDENTIFIER for this object.
2078 If no valid field is found, returns an empty RT::CustomField object.
2082 sub LoadCustomFieldByIdentifier {
2087 if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2088 $cf = RT::CustomField->new($self->CurrentUser);
2089 $cf->SetContextObject( $self );
2090 $cf->LoadById( $field->id );
2092 elsif ($field =~ /^\d+$/) {
2093 $cf = RT::CustomField->new($self->CurrentUser);
2094 $cf->SetContextObject( $self );
2095 $cf->LoadById($field);
2098 my $cfs = $self->CustomFields($self->CurrentUser);
2099 $cfs->SetContextObject( $self );
2100 $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2101 $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2106 sub ACLEquivalenceObjects { }
2108 sub BasicColumns { }
2111 return RT->Config->Get('WebPath'). "/index.html?q=";
2114 RT::Base->_ImportOverlays();