—

              
#!perl
# vim: softtabstop=4 tabstop=4 shiftwidth=4 ft=perl expandtab smarttab
# PODNAME: RT::Client::REST::Object
# ABSTRACT: base class for RT objects
use strict;
use warnings;
package RT::Client::REST::Object;
$RT::Client::REST::Object::VERSION = '0.72';
use Try::Tiny;
use Params::Validate;
use RT::Client::REST::Object::Exception;
use RT::Client::REST::SearchResult;
use DateTime;
use DateTime::Format::DateParse;
sub new {
    my $class = shift;
    if (@_ & 1) {
        RT::Client::REST::Object::OddNumberOfArgumentsException->throw;
    }
    my $self = bless {}, ref($class) || $class;
    my %opts = @_;
    my $id = delete($opts{id});
    if (defined($id)) {{
        $self->id($id);
        if ($self->can('parent_id')) {
            # If object can parent_id, we assume that it's needed for
            # retrieval.
            my $parent_id = delete($opts{parent_id});
            if (defined($parent_id)) {
                $self->parent_id($parent_id);
            } else {
                last;
            }
        }
        if ($self->autoget) {
            $self->retrieve;
        }
    }}
    while (my ($k, $v) = each(%opts)) {
        $self->$k($v);
    }
    return $self;
}
sub _generate_methods {
    my $class = shift;
    my $attributes = $class->_attributes;
    while (my ($method, $settings) = each(%$attributes)) {
        no strict 'refs'; ## no critic (ProhibitNoStrict)
        *{$class . '::' . $method} = sub {
            my $self = shift;
            if (@_) {
                my $caller = defined((caller(1))[3]) ? (caller(1))[3] : '';
                if ($settings->{validation} &&
                    # Don't validate values from the server
                    $caller ne __PACKAGE__  . '::from_form')
                {
                    my @v = @_;
                    Params::Validate::validation_options(
                        on_fail => sub {
                            no warnings 'uninitialized';
                            RT::Client::REST::Object::InvalidValueException
                            ->throw(
                            "'@v' is not a valid value for attribute '$method'"
                            );
                        },
                    );
                    validate_pos(@_, $settings->{validation});
                }
                $self->{'_' . $method} = shift;
                $self->_mark_dirty($method);
                # Let's try to autosync, shall we?  Logic is a bit hairy
                # in order to make it efficient.
                if ($self->autosync && $self->can('store') &&
                    # OK, so id is special.  This is so that 'new' would
                    # work.
                    'id' ne $method &&
                    'parent_id' ne $method &&
                    # Plus we don't want to store right after retrieving
                    # (that's where from_form is called from).
                    $caller ne __PACKAGE__  . '::from_form')
                {
                    $self->store;
                }
            }
            if ($settings->{list}) {
                my $retval = $self->{'_' . $method} || [];
                return @$retval;
            }
            else {
                return $self->{'_' . $method};
            }
        };
        if ($settings->{is_datetime}) {
            *{$class. '::' . $method . '_datetime'} = sub {
                # All dates are in UTC
                # http://requesttracker.wikia.com/wiki/REST#Data_format
                my ($self) = shift;
                if (@_) {
                    unless ($_[0]->isa('DateTime')) {
                            RT::Client::REST::Object::InvalidValueException
                                ->throw(
                                "'$_[0]' is not a valid value for attribute '${method}_datetime'"
                            );
                    }
                    my $z = $_[0]->clone;
                    $z->set_time_zone('UTC');
                    $self->$method($_[0]->strftime('%a %b %d %T %Y'));
                    return $z;
                }
                return DateTime::Format::DateParse->parse_datetime($self->$method, 'UTC');
            };
        }
        if ($settings->{list}) {
            # Generate convenience methods for list manipulation.
            my $add_method = $class . '::add_' . $method;
            my $delete_method = $class . '::delete_' . $method;
            *$add_method = sub {
                my $self = shift;
                unless (@_) {
                    RT::Client::REST::Object::NoValuesProvidedException
                        ->throw;
                }
                my @values = $self->$method;
                my %values = map { $_, 1 } @values;
                # Now add new values
                for (@_) {
                    $values{$_} = 1;
                }
                $self->$method([keys %values]);
            };
            *$delete_method = sub {
                my $self = shift;
                unless (@_) {
                    RT::Client::REST::Object::NoValuesProvidedException
                        ->throw;
                }
                my @values = $self->$method;
                my %values = map { $_, 1 } @values;
                # Now delete values
                for (@_) {
                    delete $values{$_};
                }
                $self->$method([keys %values]);
            };
        }
    }
}
sub _mark_dirty {
    my ($self, $attr) = @_;
    $self->{__dirty}{$attr} = 1;
}
sub _dirty {
    my $self = shift;
    if (exists($self->{__dirty})) {
        return keys %{$self->{__dirty}};
    }
    return;
}
sub _mark_dirty_cf {
    my ($self, $cf) = @_;
    $self->{__dirty_cf}{$cf} = 1;
}
sub _dirty_cf {
    my $self = shift;
    if (exists($self->{__dirty_cf})) {
        return keys %{$self->{__dirty_cf}};
    }
    return;
}
sub to_form {
    my ($self, $all) = @_;
    my $attributes = $self->_attributes;
    my @attrs = ($all ? keys(%$attributes) : $self->_dirty);
    my %hash;
    for my $attr (@attrs) {
        my $rest_name = (exists($attributes->{$attr}{rest_name}) ?
                         $attributes->{$attr}{rest_name} : ucfirst($attr));
        my $value;
        if (exists($attributes->{$attr}{value2form})) {
            $value = $attributes->{$attr}{value2form}($self->$attr)
        } elsif ($attributes->{$attr}{list}) {
            $value = join(',', $self->$attr)
        } else {
            $value = (defined($self->$attr) ? $self->$attr : '');
        }
        $hash{$rest_name} = $value;
    }
    my @cfs = ($all ? $self->cf : $self->_dirty_cf);
    for my $cf (@cfs) {
        $hash{'CF-' . $cf} = $self->cf($cf);
    }
    return \%hash;
}
sub from_form {
    my $self = shift;
    unless (@_) {
        RT::Client::REST::Object::NoValuesProvidedException->throw;
    }
    my $hash = shift;
    unless ('HASH' eq ref($hash)) {
        RT::Client::REST::Object::InvalidValueException->throw(
            q|Expecting a hash reference as argument to 'from_form'|,
        );
    }
    # lowercase hash keys
    my $i = 0;
    $hash = { map { ($i++ & 1) ? $_ : lc } %$hash };
    my $attributes = $self->_attributes;
    my %rest2attr;  # Mapping of REST names to our attributes;
    while (my ($attr, $settings) = each(%$attributes)) {
        my $rest_name = (exists($attributes->{$attr}{rest_name}) ?
                         lc($attributes->{$attr}{rest_name}) : $attr);
        $rest2attr{$rest_name} = [ $attr, $settings ];
    }
    # Now set attributes:
    while (my ($key, $value) = each(%$hash)) {
        # Handle custom fields, ideally /(?(1)})/ would be appened to RE
        if ( $key =~ m%^(?:cf|customfield)(?:-|\.\{)([#\s\w_:()?/-]+)% ){
             $key = $1;
            # XXX very sketchy. Will fail on long form data e.g; wiki CF
            if (defined $value and $value =~ /,/) {
                $value = [ split(/\s*,\s*/, $value) ];
            }
            $self->cf($key, $value);
            next
        }
        unless (exists($rest2attr{$key})) {
            warn "Unknown key: $key\n";
            next;
        }
        my ($method, $settings)  = @{$rest2attr{$key}};
        if ($settings->{is_datetime} and $value eq 'Not set') {
            $value = undef
        }
        if (exists($attributes->{$method}{form2value})) {
            $value = $attributes->{$method}{form2value}($value);
        }
        elsif ($attributes->{$method}{list}) {
            $value = defined $value ? [split(/\s*,\s*/, $value)] : []
        }
        $self->$method($value);
    }
    return;
}
sub retrieve {
    my $self = shift;
    $self->_assert_rt_and_id;
    my $rt = $self->rt;
    my ($hash) = $rt->show(type => $self->rt_type, id => $self->id);
    $self->from_form($hash);
    $self->{__dirty} = {};
    $self->{__dirty_cf} = {};
    return $self;
}
sub store {
    my $self = shift;
    $self->_assert_rt;
    my $rt = $self->rt;
    if (defined($self->id)) {
        $rt->edit(
            type    => $self->rt_type,
            id      => $self->id,
            set     => $self->to_form,
        );
    }
    else {
        my $id = $rt->create(
            type    => $self->rt_type,
            set     => $self->to_form,
            @_,
        );
        $self->id($id);
    }
    $self->{__dirty} = {};
    return $self;
}
sub search {
    my $self = shift;
    if (@_ & 1) {
        RT::Client::REST::Object::OddNumberOfArgumentsException->throw;
    }
    $self->_assert_rt;
    my %opts = @_;
    my $limits = delete($opts{limits}) || [];
    my $query = '';
    for my $limit (@$limits) {
        my $kw;
        try {
            $kw = $self->_attr2keyword($limit->{attribute});
        }
        catch {
            die $_ unless blessed $_ && $_->can('rethrow');
            if ($_->isa('RT::Clite::REST::Object::InvalidAttributeException')) {
                RT::Client::REST::Object::InvalidSearchParametersException
                    ->throw(shift->message);
            }
            else {
                $_->rethrow
            }
        };
        my $op = $limit->{operator};
        my $val = $limit->{value};
        my $agg = $limit->{aggregator} || 'and';
        if (length($query)) {
            $query = "($query) $agg $kw $op '$val'";
        } else {
            $query = "$kw $op '$val'";
        }
    }
    my $orderby;
    try {
        # Defaults to 'id' at the moment.  Do not rely on this --
        # implementation may change!
        $orderby = (delete($opts{reverseorder}) ? '-' : '+') .
            ($self->_attr2keyword(delete($opts{orderby}) || 'id'));
    }
    catch {
        die $_ unless blessed $_ && $_->can('rethrow');
        if ($_->isa('RT::Client::REST::Object::InvalidAttributeException')) {
            RT::Client::REST::Object::InvalidSearchParametersException->throw(
                shift->message,
            )
        }
        else {
            $_->rethrow;
        }
    };
    my $rt = $self->rt;
    my @results;
    try {
        @results = $rt->search(
            type => $self->rt_type,
            query => $query,
            orderby => $orderby,
        );
    }
    catch {
        die $_ unless blessed $_ && $_->can('rethrow');
        if ($_->isa('RT::Client::REST::InvalidQueryException')) {
            RT::Client::REST::Object::InvalidSearchParametersException->throw;
        }
        else {
            $_->rethrow;
        }
    };
    return RT::Client::REST::SearchResult->new(
        ids => \@results,
        object => sub { $self->new(id => shift, rt => $rt) },
    );
}
sub count {
    my $self = shift;
    $self->_assert_rt;
    return $self->search(@_)->count;
}
sub _attr2keyword {
    my ($self, $attr) = @_;
    my $attributes = $self->_attributes;
    unless (exists($attributes->{$attr})) {
        no warnings 'uninitialized';
        RT::Clite::REST::Object::InvalidAttributeException->throw(
            "Attribute '$attr' does not exist in object type '" .
                ref($self) . "'"
        );
    }
    return (exists($attributes->{$attr}{rest_name}) ?
            $attributes->{$attr}{rest_name} :
            ucfirst($attr));
}
sub _assert_rt_and_id {
    my $self = shift;
    my $method = shift || (caller(1))[3];
    unless (defined($self->rt)) {
        RT::Client::REST::Object::RequiredAttributeUnsetException
            ->throw("Cannot '$method': 'rt' attribute of the object ".
                    "is not set");
    }
    unless (defined($self->id)) {
        RT::Client::REST::Object::RequiredAttributeUnsetException
            ->throw("Cannot '$method': 'id' attribute of the object ".
                    "is not set");
    }
}
sub _assert_rt {
    my $self = shift;
    my $method = shift || (caller(1))[3];
    unless (defined($self->rt)) {
        RT::Client::REST::Object::RequiredAttributeUnsetException
            ->throw("Cannot '$method': 'rt' attribute of the object ".
                    "is not set");
    }
}
sub param {
    my $self = shift;
    unless (@_) {
        RT::Client::REST::Object::NoValuesProvidedException->throw;
    }
    my $name = shift;
    if (@_) {
        $self->{__param}{$name} = shift;
    }
    return $self->{__param}{$name};
}
sub cf {
    my $self = shift;
    unless (@_) {
        # Return a list of CFs.
        return keys %{$self->{__cf}};
    }
    my $name = shift;
    if ('HASH' eq ref($name)) {
        while (my ($k, $v) = each(%$name)) {
            $self->{__cf}{lc($k)} = $v;
            $self->_mark_dirty_cf($k);
        }
        return keys %{$self->{__cf}};
    } else {
        $name = lc $name;
        if (@_) {
            $self->{__cf}{$name} = shift;
            $self->_mark_dirty_cf($name);
        }
        return $self->{__cf}{$name};
    }
}
sub rt {
    my $self = shift;
    if (@_) {
        my $rt = shift;
        unless (UNIVERSAL::isa($rt, 'RT::Client::REST')) {
            RT::Client::REST::Object::InvalidValueException->throw;
        }
        $self->{__rt} = $rt;
    }
    return $self->{__rt};
}
sub use_single_rt {
    my ($class, $rt) = @_;
    unless (UNIVERSAL::isa($rt, 'RT::Client::REST')) {
        RT::Client::REST::Object::InvalidValueException->throw;
    }
    no strict 'refs'; ## no critic (ProhibitNoStrict)
    no warnings 'redefine';
    *{(ref($class) || $class) . '::rt'} = sub { $rt };
}
sub autostore {}
sub use_autostore {
    my ($class, $autostore) = @_;
    no strict 'refs'; ## no critic (ProhibitNoStrict)
    no warnings 'redefine';
    *{(ref($class) || $class) . '::autostore'} = sub { $autostore };
}
sub DESTROY {
    my $self = shift;
    $self->autostore && $self->can('store') && $self->store;
}
sub autoget {}
sub use_autoget {
    my ($class, $autoget) = @_;
    no strict 'refs'; ## no critic (ProhibitNoStrict)
    no warnings 'redefine';
    *{(ref($class) || $class) . '::autoget'} = sub { $autoget };
}
sub autosync {}
sub use_autosync {
    my ($class, $autosync) = @_;
    no strict 'refs'; ## no critic (ProhibitNoStrict)
    no warnings 'redefine';
    *{(ref($class) || $class) . '::autosync'} = sub { $autosync };
}
sub be_transparent {
    my ($class, $rt) = @_;
    $class->use_autosync(1);
    $class->use_autoget(1);
    $class->use_single_rt($rt);
}
1;
__END__
HideShow 361 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
RT::Client::REST::Object - base class for RT objects
=head1 VERSION
version 0.72
=head1 SYNOPSIS
  # Create a new type
  package RT::Client::REST::MyType;
  use parent qw(RT::Client::REST::Object);
  sub _attributes {{
    myattribute => {
      validation => {
        type => SCALAR,
      },
    },
  }}
  sub rt_type { "mytype" }
  1;
=head1 DESCRIPTION
The RT::Client::REST::Object module is a superclass providing a whole
bunch of class and object methods in order to streamline the development
of RT's REST client interface.
=head1 ATTRIBUTES
Attributes are defined by method C<_attributes> that should be defined
in your class.  This method returns a reference to a hash whose keys are
the attributes.  The values of the hash are attribute settings, which are
as follows:
=over 2
=item list
If set to true, this is a list attribute.  See
L</LIST ATTRIBUTE PROPERTIES> below.
=item validation
A hash reference.  This is passed to validation routines when associated
mutator is called.  See L<Params::Validate> for reference.
=item rest_name
=for stopwords FinalPriority
This specifies this attribute's REST name.  For example, attribute
"final_priority" corresponds to RT REST's "FinalPriority".  This option
may be omitted if the two only differ in first letter capitalization.
=item form2value
Convert form value (one that comes from the server) into attribute-digestible
format.
=item value2form
Convert value into REST form format.
=back
Example:
  sub _attributes {{
    id  => {
        validation  => {
            type    => SCALAR,
            regex   => qr/^\d+$/,
        },
        form2value  => sub {
            shift =~ m~^ticket/(\d+)$~i;
            return $1;
        },
        value2form  => sub {
            return 'ticket/' . shift;
        },
    },
    admin_cc        => {
        validation  => {
            type    => ARRAYREF,
        },
        list        => 1,
        rest_name   => 'AdminCc',
    },
  }}
=head1 LIST ATTRIBUTE PROPERTIES
List attributes have the following properties:
=over 2
=item *
When called as accessors, return a list of items
=item *
When called as mutators, only accept an array reference
=item *
Convenience methods "add_attr" and "delete_attr" are available.  For
example:
  # Get the list
  my @requestors = $ticket->requestors;
  # Replace with a new list
  $ticket->requestors( [qw(dude@localhost)] );
  # Add some random guys to the current list
  $ticket->add_requestors('randomguy@localhost', 'evil@local');
=back
=for stopwords autoget autostore autosync
=head1 SPECIAL ATTRIBUTES
B<id> and B<parent_id> are special attributes.  They are used by
various DB-related methods and are especially relied upon by:
=over 2
=item autostore
=item autosync
=item autoget
=back
=head1 METHODS
=over 2
=item new
Constructor
=item _generate_methods
This class method generates accessors and mutators based on
B<_attributes> method which your class should provide.  For items
that are lists, 'add_' and 'delete_' methods are created.  For instance,
the following two attributes specified in B<_attributes> will generate
methods 'creator', 'cc', 'add_cc', and 'delete_cc':
  creator => {
    validation => { type => SCALAR },
  },
  cc => {
    list => 1,
    validation => { type => ARRAYREF },
  },
=item _mark_dirty($attrname)
Mark an attribute as dirty.
=item _dirty
Return the list of dirty attributes.
=item _mark_dirty_cf($attrname)
Mark an custom flag as dirty.
=item _dirty_cf
Return the list of dirty custom flags.
=item to_form($all)
Convert the object to 'form' (used by REST protocol). This is done based on
B<_attributes> method. If C<$all> is true, create a form from all of the
object's attributes and custom flags, otherwise use only dirty (see B<_dirty>
method) attributes and custom flags. Defaults to the latter.
=item from_form
Set object's attributes from form received from RT server.
=item param($name, $value)
Set an arbitrary parameter.
=item cf([$name, [$value]])
Given no arguments, returns the list of custom field names.  With
one argument, returns the value of custom field C<$name>.  With two
arguments, sets custom field C<$name> to C<$value>.  Given a reference
to a hash, uses it as a list of custom fields and their values, returning
the new list of all custom field names.
=item rt
Get or set the 'rt' object, which should be of type L<RT::Client::REST>.
=back
=head1 DB METHODS
The following are methods that have to do with reading, creating, updating,
and searching objects.
=over 2
=item count
Takes the same arguments as C<search()> but returns the actual count of
the found items.  Throws the same exceptions.
=item retrieve
Retrieve object's attributes.  Note that 'id' attribute must be set for this
to work.
=item search (%opts)
This method is used for searching objects.  It returns an object of type
L<RT::Client::REST::SearchResult>, which can then be used to process
results.  C<%opts> is a list of key-value pairs, which are as follows:
=over 2
=item limits
This is a reference to array containing hash references with limits to
apply to the search (think SQL limits).
=for stopwords orderby reverseorder
=item orderby
Specifies attribute to sort the result by (in ascending order).
=item reverseorder
If set to a true value, sorts by attribute specified by B<orderby> in
descending order.
=back
If the client cannot construct the query from the specified arguments,
or if the server cannot make it out,
C<RT::Client::REST::Object::InvalidSearchParametersException> is thrown.
=item store
Store the object.  If 'id' is set, this is an update; otherwise, a new
object is created and the 'id' attribute is set.  Note that only changed
(dirty) attributes are sent to the server.
=back
=head1 CLASS METHODS
=over 2
=item use_single_rt
=for stopwords instantiations
This method takes a single argument -- L<RT::Client::REST> object
and makes this class use it for all instantiations.  For example:
  my $rt = RT::Client::REST->new(%args);
  # Make all tickets use this RT:
  RT::Client::REST::Ticket->use_single_rt($rt);
  # Now make all objects use it:
  RT::Client::REST::Object->use_single_rt($rt);
=for stopwords autostoring autostore
=item use_autostore
Turn I<autostoring> on and off.  I<Autostoring> means that you do not have
to explicitly call C<store()> on an object - it will be called when
the object goes out of scope.
  # Autostore tickets:
  RT::Client::REST::Ticket->use_autostore(1);
  my $ticket = RT::Client::REST::Ticket->new(%opts)->retrieve;
  $ticket->priority(10);
  # Don't have to call store().
=item use_autoget
Turn I<autoget> feature on or off (off by default). When set to on,
C<retrieve()> will be automatically called from the constructor if
it is called with that object's special attributes (see
L</SPECIAL ATTRIBUTES> above).
  RT::Client::Ticket->use_autoget(1);
  my $ticket = RT::Client::Ticket->new(id => 1);
  # Now all attributes are available:
  my $subject = $ticket->subject;
=for stopwords autosync
=item use_autosync
Turn I<autosync> feature on or off (off by default).  When set, every time
an attribute is changed, C<store()> method is invoked.  This may be pretty
expensive.
=item be_transparent
This turns on B<autosync> and B<autoget>.  Transparency is a neat idea,
but it may be expensive and slow.  Depending on your circumstances, you
may want a finer control of your objects.  Transparency makes
C<retrieve()> and C<store()> calls invisible:
  RT::Client::REST::Ticket->be_transparent($rt);
  my $ticket = RT::Client::REST::Ticket->new(id => $id); # retrieved
  $ticket->add_cc('you@localhost.localdomain'); # stored
  $ticket->status('stalled'); # stored
  # etc.
Do not forget to pass RT::Client::REST object to this method.
=back
=head1 SEE ALSO
L<RT::Client::REST::Ticket>,
L<RT::Client::REST::SearchResult>.
=head1 AUTHOR
Dean Hamstead <dean@fragfest.com.au>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2023, 2020 by Dmitri Tikhonov.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut