+ my $remote_uri = RT::URI->new( $self->CurrentUser );
+ if ($remote_uri->FromURI( $remote_link )) {
+ # Enforce the remote end of StrictLinkACL
+ my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
+ if ($remote_obj and $remote_obj->id and RT->Config->Get("StrictLinkACL")) {
+ my $right = $remote_obj->ModifyLinkRight;
+
+ return (0, $self->loc("Permission denied"))
+ if $right and
+ not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
+ }
+ } else {
+ return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
+ }
+
+ my $link = RT::Link->new( $self->CurrentUser );
+ $RT::Logger->debug( "Trying to load link: "
+ . $args{'Base'} . " "
+ . $args{'Type'} . " "
+ . $args{'Target'} );
+
+ $link->LoadByParams(
+ Base => $args{'Base'},
+ Type => $args{'Type'},
+ Target => $args{'Target'}
+ );
+
+ unless ($link->id) {
+ $RT::Logger->debug("Couldn't find that link");
+ return ( 0, $self->loc("Link not found") );
+ }
+
+ my $basetext = $self->FormatLink(Object => $link->BaseObj,
+ FallBack => $args{Base});
+ my $targettext = $self->FormatLink(Object => $link->TargetObj,
+ FallBack => $args{Target});
+ my $typetext = $self->FormatType(Type => $args{Type});
+ my $TransString = "$basetext no longer $typetext $targettext.";
+
+ my ($ok, $msg) = $link->Delete();
+ unless ($ok) {
+ RT->Logger->error("Link could not be deleted: $msg");
+ return ( 0, $self->loc("Link could not be deleted: [_1]", $msg) );
+ }
+
+ # No transactions for you!
+ return (1, $TransString) if $args{'Silent'};
+
+ my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
+
+ # Some transactions?
+ unless ( $args{ 'Silent'. $direction } ) {
+ my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
+ Type => 'DeleteLink',
+ Field => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
+ OldValue => $remote_uri->URI || $remote_link,
+ TimeTaken => 0
+ );
+ $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
+ }
+
+ if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
+ my $OtherObj = $remote_uri->Object;
+ my ( $val, $msg ) = $OtherObj->_NewTransaction(
+ Type => 'DeleteLink',
+ Field => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
+ OldValue => $self->URI,
+ TimeTaken => 0,
+ );
+ $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
+ }
+
+ return (1, $TransString);
+}
+
+=head1 LockForUpdate
+
+In a database transaction, gains an exclusive lock on the row, to
+prevent race conditions. On SQLite, this is a "RESERVED" lock on the
+entire database.
+
+=cut
+
+sub LockForUpdate {
+ my $self = shift;
+
+ my $pk = $self->_PrimaryKey;
+ my $id = @_ ? $_[0] : $self->$pk;
+ $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
+ if (RT->Config->Get('DatabaseType') eq "SQLite") {
+ # SQLite does DB-level locking, upgrading the transaction to
+ # "RESERVED" on the first UPDATE/INSERT/DELETE. Do a no-op
+ # UPDATE to force the upgade.
+ return RT->DatabaseHandle->dbh->do(
+ "UPDATE " .$self->Table.
+ " SET $pk = $pk WHERE 1 = 0");
+ } else {
+ return $self->_LoadFromSQL(
+ "SELECT * FROM ".$self->Table
+ ." WHERE $pk = ? FOR UPDATE",
+ $id,
+ );
+ }
+}
+
+=head2 _NewTransaction PARAMHASH
+
+Private function to create a new RT::Transaction object for this ticket update
+
+=cut
+
+sub _NewTransaction {
+ my $self = shift;
+ my %args = (
+ TimeTaken => undef,
+ Type => undef,
+ OldValue => undef,
+ NewValue => undef,
+ OldReference => undef,
+ NewReference => undef,
+ ReferenceType => undef,
+ Data => undef,
+ Field => undef,
+ MIMEObj => undef,
+ ActivateScrips => 1,
+ CommitScrips => 1,
+ SquelchMailTo => undef,
+ CustomFields => {},
+ @_
+ );
+
+ my $in_txn = RT->DatabaseHandle->TransactionDepth;
+ RT->DatabaseHandle->BeginTransaction unless $in_txn;
+
+ $self->LockForUpdate;
+
+ my $old_ref = $args{'OldReference'};
+ my $new_ref = $args{'NewReference'};
+ my $ref_type = $args{'ReferenceType'};
+ if ($old_ref or $new_ref) {
+ $ref_type ||= ref($old_ref) || ref($new_ref);
+ if (!$ref_type) {
+ $RT::Logger->error("Reference type not specified for transaction");
+ return;
+ }
+ $old_ref = $old_ref->Id if ref($old_ref);
+ $new_ref = $new_ref->Id if ref($new_ref);
+ }
+
+ require RT::Transaction;
+ my $trans = RT::Transaction->new( $self->CurrentUser );
+ my ( $transaction, $msg ) = $trans->Create(
+ ObjectId => $self->Id,
+ ObjectType => ref($self),
+ TimeTaken => $args{'TimeTaken'},
+ Type => $args{'Type'},
+ Data => $args{'Data'},
+ Field => $args{'Field'},
+ NewValue => $args{'NewValue'},
+ OldValue => $args{'OldValue'},
+ NewReference => $new_ref,
+ OldReference => $old_ref,
+ ReferenceType => $ref_type,
+ MIMEObj => $args{'MIMEObj'},
+ ActivateScrips => $args{'ActivateScrips'},
+ CommitScrips => $args{'CommitScrips'},
+ SquelchMailTo => $args{'SquelchMailTo'},
+ CustomFields => $args{'CustomFields'},
+ );
+
+ # Rationalize the object since we may have done things to it during the caching.
+ $self->Load($self->Id);
+
+ $RT::Logger->warning($msg) unless $transaction;
+
+ $self->_SetLastUpdated;
+
+ if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
+ $self->_UpdateTimeTaken( $args{'TimeTaken'}, Transaction => $trans );
+ }
+ if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
+ push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
+ }
+
+ RT->DatabaseHandle->Commit unless $in_txn;
+
+ return ( $transaction, $msg, $trans );
+}
+
+
+
+=head2 Transactions
+
+Returns an L<RT::Transactions> object of all transactions on this record object
+
+=cut
+
+sub Transactions {
+ my $self = shift;
+
+ my $transactions = RT::Transactions->new( $self->CurrentUser );
+ $transactions->Limit(
+ FIELD => 'ObjectId',
+ VALUE => $self->id,
+ );
+ $transactions->Limit(
+ FIELD => 'ObjectType',
+ VALUE => ref($self),
+ );
+
+ return $transactions;
+}
+
+=head2 SortedTransactions
+
+Returns the result of L</Transactions> ordered per the
+I<OldestTransactionsFirst> preference/option.
+
+=cut
+
+sub SortedTransactions {
+ my $self = shift;
+ my $txns = $self->Transactions;
+ my $order = RT->Config->Get("OldestTransactionsFirst", $self->CurrentUser)
+ ? 'ASC' : 'DESC';
+ $txns->OrderByCols(
+ { FIELD => 'Created', ORDER => $order },
+ { FIELD => 'id', ORDER => $order },
+ );
+ return $txns;
+}
+
+our %TRANSACTION_CLASSIFICATION = (
+ Create => 'message',
+ Correspond => 'message',
+ Comment => 'message',
+
+ AddWatcher => 'people',
+ DelWatcher => 'people',
+
+ Take => 'people',
+ Untake => 'people',
+ Force => 'people',
+ Steal => 'people',
+ Give => 'people',
+
+ AddLink => 'links',
+ DeleteLink => 'links',
+
+ Status => 'basics',
+ Set => {
+ __default => 'basics',
+ map( { $_ => 'dates' } qw(
+ Told Starts Started Due LastUpdated Created LastUpdated
+ ) ),
+ map( { $_ => 'people' } qw(
+ Owner Creator LastUpdatedBy
+ ) ),
+ },
+ SystemError => 'error',
+ AttachmentTruncate => 'attachment-truncate',
+ AttachmentDrop => 'attachment-drop',
+ AttachmentError => 'error',
+ __default => 'other',
+);
+
+sub ClassifyTransaction {
+ my $self = shift;
+ my $txn = shift;
+
+ my $type = $txn->Type;
+
+ my $res = $TRANSACTION_CLASSIFICATION{ $type };
+ return $res || $TRANSACTION_CLASSIFICATION{ '__default' }
+ unless ref $res;
+
+ return $res->{ $txn->Field } || $res->{'__default'}
+ || $TRANSACTION_CLASSIFICATION{ '__default' };
+}
+
+=head2 Attachments
+
+Returns an L<RT::Attachments> object of all attachments on this record object
+(for all its L</Transactions>).
+
+By default Content and Headers of attachments are not fetched right away from
+database. Use C<WithContent> and C<WithHeaders> options to override this.
+
+=cut
+
+sub Attachments {
+ my $self = shift;
+ my %args = (
+ WithHeaders => 0,
+ WithContent => 0,
+ @_
+ );
+ my @columns = grep { not /^(Headers|Content)$/ }
+ RT::Attachment->ReadableAttributes;
+ push @columns, 'Headers' if $args{'WithHeaders'};
+ push @columns, 'Content' if $args{'WithContent'};
+
+ my $res = RT::Attachments->new( $self->CurrentUser );
+ $res->Columns( @columns );
+ my $txn_alias = $res->TransactionAlias;
+ $res->Limit(
+ ALIAS => $txn_alias,
+ FIELD => 'ObjectType',
+ VALUE => ref($self),
+ );
+ $res->Limit(
+ ALIAS => $txn_alias,
+ FIELD => 'ObjectId',
+ VALUE => $self->id,
+ );
+ return $res;
+}
+
+=head2 TextAttachments
+
+Returns an L<RT::Attachments> object of all attachments, like L<Attachments>,
+but only those that are text.
+
+By default Content and Headers are fetched. Use C<WithContent> and
+C<WithHeaders> options to override this.
+
+=cut
+
+sub TextAttachments {
+ my $self = shift;
+ my $res = $self->Attachments(
+ WithHeaders => 1,
+ WithContent => 1,
+ @_
+ );
+ $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text/plain');
+ $res->Limit( FIELD => 'ContentType', OPERATOR => 'STARTSWITH', VALUE => 'message/');
+ $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text');
+ $res->Limit( FIELD => 'Filename', OPERATOR => 'IS', VALUE => 'NULL')
+ if RT->Config->Get( 'SuppressInlineTextFiles', $self->CurrentUser );
+ return $res;
+}
+
+sub CustomFields {
+ my $self = shift;
+ my $cfs = RT::CustomFields->new( $self->CurrentUser );
+
+ $cfs->SetContextObject( $self );
+ # XXX handle multiple types properly
+ $cfs->LimitToLookupType( $self->CustomFieldLookupType );
+ $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
+ $cfs->ApplySortOrder;
+
+ return $cfs;
+}
+
+# TODO: This _only_ works for RT::Foo classes. it doesn't work, for
+# example, for RT::IR::Foo classes.
+
+sub CustomFieldLookupId {
+ my $self = shift;
+ my $lookup = shift || $self->CustomFieldLookupType;
+ my @classes = ($lookup =~ /RT::(\w+)-/g);
+
+ # Work on "RT::Queue", for instance
+ return $self->Id unless @classes;
+
+ my $object = $self;
+ # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
+ my $final = shift @classes;
+ foreach my $class (reverse @classes) {
+ my $method = "${class}Obj";
+ $object = $object->$method;
+ }
+
+ my $id = $object->$final;
+ unless (defined $id) {
+ my $method = "${final}Obj";
+ $id = $object->$method->Id;
+ }
+ return $id;
+}
+
+
+=head2 CustomFieldLookupType
+
+Returns the path RT uses to figure out which custom fields apply to this object.
+
+=cut
+
+sub CustomFieldLookupType {
+ my $self = shift;
+ return ref($self) || $self;
+}
+
+
+=head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
+
+VALUE should be a string. FIELD can be any identifier of a CustomField
+supported by L</LoadCustomFieldByIdentifier> method.
+
+Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
+deletes the old value.
+If VALUE is not a valid value for the custom field, returns
+(0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
+$id is ID of created L<ObjectCustomFieldValue> object.
+
+=cut
+
+sub AddCustomFieldValue {
+ my $self = shift;
+ $self->_AddCustomFieldValue(@_);
+}
+
+sub _AddCustomFieldValue {
+ my $self = shift;
+ my %args = (
+ Field => undef,
+ Value => undef,
+ LargeContent => undef,
+ ContentType => undef,
+ RecordTransaction => 1,
+ @_
+ );
+
+ my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
+ unless ( $cf->Id ) {
+ return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
+ }
+
+ my $OCFs = $self->CustomFields;
+ $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
+ unless ( $OCFs->Count ) {
+ return (
+ 0,
+ $self->loc(
+ "Custom field [_1] does not apply to this object",
+ ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
+ )
+ );
+ }
+
+ # empty string is not correct value of any CF, so undef it
+ foreach ( qw(Value LargeContent) ) {
+ $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
+ }
+
+ unless ( $cf->ValidateValue( $args{'Value'} ) ) {
+ return ( 0, $self->loc("Invalid value for custom field") );
+ }
+
+ # If the custom field only accepts a certain # of values, delete the existing
+ # value and record a "changed from foo to bar" transaction
+ unless ( $cf->UnlimitedValues ) {
+
+ # Load up a ObjectCustomFieldValues object for this custom field and this ticket
+ my $values = $cf->ValuesForObject($self);
+
+ # We need to whack any old values here. In most cases, the custom field should
+ # only have one value to delete. In the pathalogical case, this custom field
+ # used to be a multiple and we have many values to whack....
+ my $cf_values = $values->Count;
+
+ if ( $cf_values > $cf->MaxValues ) {
+ my $i = 0; #We want to delete all but the max we can currently have , so we can then
+ # execute the same code to "change" the value from old to new
+ while ( my $value = $values->Next ) {
+ $i++;
+ if ( $i < $cf_values ) {
+ my ( $val, $msg ) = $cf->DeleteValueForObject(
+ Object => $self,
+ Id => $value->id,
+ );
+ unless ($val) {
+ return ( 0, $msg );
+ }
+ my ( $TransactionId, $Msg, $TransactionObj ) =
+ $self->_NewTransaction(
+ Type => 'CustomField',
+ Field => $cf->Id,
+ OldReference => $value,
+ );
+ }
+ }
+ $values->RedoSearch if $i; # redo search if have deleted at least one value
+ }
+
+ if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
+ return $entry->id;
+ }
+
+ my $old_value = $values->First;
+ my $old_content;
+ $old_content = $old_value->Content if $old_value;
+
+ my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
+ Object => $self,
+ Content => $args{'Value'},
+ LargeContent => $args{'LargeContent'},
+ ContentType => $args{'ContentType'},
+ );
+
+ unless ( $new_value_id ) {
+ return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
+ }
+
+ my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
+ $new_value->Load( $new_value_id );
+
+ # now that adding the new value was successful, delete the old one
+ if ( $old_value ) {
+ my ( $val, $msg ) = $old_value->Delete();
+ return ( 0, $msg ) unless $val;
+ }