Mailing List Archive

Author: autrijus
Date: Wed May 12 09:03:32 2004
New Revision: 877

Modified:
RT-Client/ (props changed)
RT-Client/lib/RT/Client.pm
RT-Client/lib/RT/Client/Base.pm
RT-Client/t/1-procedural.t
Log:
----------------------------------------------------------------------
r4788@not: autrijus | 2004-05-12T13:02:51.402966Z

* finished testing for ->current_user().
* more refactoring as usual.
----------------------------------------------------------------------


Modified: RT-Client/lib/RT/Client.pm
==============================================================================
--- RT-Client/lib/RT/Client.pm (original)
+++ RT-Client/lib/RT/Client.pm Wed May 12 09:03:32 2004
@@ -23,7 +23,7 @@

field path => '/Atom/0.3/';
field server => 'localhost';
-field encoding => 'utf-8';
+field encoding => 'UTF-8';
field 'ua';
field 'current_user';
field 'status';
@@ -54,7 +54,19 @@

sub munge_request {
my $req = shift;
- $req->header( 'Accept' => 'application/x.atom+xml, application/xml, text/xml, */*' );
+ $req->header(
+ 'Accept' => join(
+ ', ',
+ 'application/x.atom+xml', 'application/xml', 'text/xml', '*/*',
+ )
+ );
+ $req->header(
+ 'Content-Type' => join(
+ '; ',
+ ($req->content_type || 'text/plain'),
+ 'charset='.$self->encoding
+ )
+ );
$req->header( 'Accept-Charset' => $self->encoding );
$req->header( 'X-RT-CurrentUser' => $self->current_user );
return $req;
@@ -65,24 +77,36 @@
entry => 'RT::Client::Object',
};

-sub describe {
- my $res = $self->_request(@_, method => 'OPTIONS') or return undef;
+sub _spawn {
+ my $res = shift;
$res->content =~ /<(\w+)/ or return $res->content;

my $class = $self->_describe_map->{$1} or die "Sorry, type $1 not handled yet";
return $class->new(Client => $self, Stream => \$res->content, URI => $res->base);
}

+sub describe {
+ my $res = $self->_request(@_, method => 'OPTIONS') or return undef;
+ return $self->_spawn($res);
+}
+
+stub 'search';
+
sub get {
- my $res = $self->_request(@_, method => 'GET') or return undef;
- $res = $self->_request(@_, method => 'GET') or return undef; # XXX - investigate cache issues
- $res->content =~ /<(\w+)/ or return $res->content;
+ my $res = $self->_request(@_, method => 'OPTIONS'); # XXX - ditch this asap
+ $res = $self->_request(@_, method => 'GET') or return undef;
+ return $self->_spawn($res);
}

sub set {
splice(@_, 1, 0, 'content') if (@_ == 2 and $_[0] ne 'URI');
my $res = $self->_request(@_, method => 'PUT') or return undef;
- $res->content =~ /<(\w+)/ or return $res->content;
+ return $self->_spawn($res);
+}
+
+sub remove {
+ my $res = $self->_request(@_, method => 'DELETE') or return undef;
+ return $self->_spawn($res);
}

sub add {
@@ -139,7 +163,7 @@
my $res = $self->make_request($req);
$self->status($res->code);

- if ($res->code >= 400) {
+ if ($res->is_error) {
$self->errstr($res->content);
return;
}

Modified: RT-Client/lib/RT/Client/Base.pm
==============================================================================
--- RT-Client/lib/RT/Client/Base.pm (original)
+++ RT-Client/lib/RT/Client/Base.pm Wed May 12 09:03:32 2004
@@ -42,7 +42,10 @@
my ($member, $action) = split(/!/, $link->title, 2);
next if $member =~ /^_/;

- XXX("member link not handled") if $member;
+ if ($member) {
+ next;
+ XXX("member link not handled");
+ }

$action ||= $self->_rel_map->{$rel} or die "rel not handled: $rel";
$self->actions->{$action} = $link->href;

Modified: RT-Client/t/1-procedural.t
==============================================================================
--- RT-Client/t/1-procedural.t (original)
+++ RT-Client/t/1-procedural.t Wed May 12 09:03:32 2004
@@ -35,6 +35,8 @@
is($rt->get(URI => "$uri.Subject"), 'Testing', '->get(URI => .Subject)');
is($rt->get("$uri.Subject"), 'Testing', '->get(.Subject)');
is($rt->get("$uri.Queue"), 1, '->get(.Queue)');
+is($rt->get("$uri/Requestors.Count"), 1, '->get(Requestors.Count)');
+is($rt->get("$uri/Requestors/*1.Name"), 'root', '->get(Requestors/*1.Name) is root');

is($rt->set("$uri.Subject", 'Set0'), 'Set0', '->set(.Subject)');
is($rt->get("$uri.Subject"), 'Set0', '->set(.Subject) really happened');
@@ -49,26 +51,33 @@
ok($rt->update($uri, Subject => { set => [ 'Fnord', 'Set4' ] }), '->update with set + multival');
is($rt->get("$uri.Subject"), 'Set4', '->update really happened');

-exit;
-
-__END__
-my $queue = $rt->get($rt->get("$uri.QueueObj"));
-isa_ok($queue, 'RT::Client::Object');
+my $queue = $rt->get("$uri.QueueObj");
+isa_ok($queue, 'RT::Client::Object', '->QueueObj');
+is($rt->get($queue->uri.".Id"), 1, '->QueueObj has an Id');

# 1.1 Independent of CLI login credentials, need ability to specify
# "requestor" field so that replies are sent to the requestor.

-my $email = 'rand-' . rand() . '@example.com';
-is($ticket->Requestor->search->count, 1);
-$ticket->addRequestor($email);
-is($ticket->Requestor->search->count, 2);
+$rt->current_user('RT_System');
+$ticket = $rt->add('Tickets', Queue => 1, Subject => 'By System');
+is($rt->current_user, 'RT_System', 'current_user persists over a request');
+$rt->current_user($rt->username);
+
+isa_ok($ticket, 'RT::Client::Object');
+$uri = $ticket->uri;
+isnt($uri, undef, 'New Ticket has a URI: '.$uri);
+is($rt->get("$uri/Requestors/*1.Name"), 'RT_System', '->get(Requestors/*1.Name) is RT_System');

# 1.2 Ability to post a ticket to a specific queue.

-$ticket = $queue->Tickets->add( Subject => 'Testing' );
+$ticket = $rt->add('Tickets', Queue => 'General', Subject => 'Queue ByName');
isa_ok($ticket, 'RT::Client::Object');
-is($ticket->Subject, 'Testing');
+$uri = $ticket->uri;
+isnt($uri, undef, 'New Ticket has a URI: '.$uri);
+is($rt->get("$uri.Queue"), 1, 'posted to the 1st queue');

+exit;
+__END__
# 1.3 Ability to specify message body. May contain utf8 OR localized
# charset.

_______________________________________________
Rt-commit mailing list
Rt-commit@lists.bestpractical.com
http://lists.bestpractical.com/cgi-bin/mailman/listinfo/rt-commit