File Coverage

blib/lib/Net/ThirtySevenSignals/Highrise.pm

Criterion	Covered	Total	%
statement	31	33	93.9
branch			n/a
condition			n/a
subroutine	11	11	100.0
pod			n/a
total	42	44	95.4

# $Id: Backpack.pm 29 2008-07-13 10:35:47Z dave $

=head1 NAME

Net::ThirtySevenSignals::Highrise - Perl extension for talking 37Signals' Highrise API

=head1 SYNOPSIS

  use Net::ThirtySevenSignals::Highrise;

  my $hr = Net::ThirtySevenSignals::Highrise(
                         user  => $your_highrise_url_prefix,
                         token => $your_highrise_api_token,
                         ssl   => $use_ssl);

  # Fill out a Perl data structure with information about
  my $people = $hr->list_all_people;

  # return a hashref of people
  my $people = $hr->people_list_by_criteria(email => '[e-mail]');


=head1 DESCRIPTION

Net::ThirtySevenSignals::Highrise provides a thin Perl wrapper around the Highrise API
(L). Currently it only implements a very few
API points.

The API is unstable at this time.


=head2 Getting Started

In order to use the Highrise API, you'll need to have a Highrise
API token. And in order to get one of those, you'll need a Highrise
account. But then again, the API will be pretty useless to you if
you don't have a Highrise account to manipulate with it.

You can get a Highrise account from L.

=head2 Highrise API

The Highrise API is based on XML over HTTP. You send an XML message
over HTTP to the Highrise server and the server sends a response to
you which is also in XML. The format of the various XML requests and
responses are defined at L

This module removes the need to deal with any XML. You create an
object to talk to the Highrise server and call methods on that object
to manipulate your data. The values returned from Highrise
are converted to Perl data structures before being handed back to
you (although it is also possible to get back the raw XML).

=head1 XML

To get the XML back from the API, you can pass the parameter C
=E 0> to the C function.

=cut

package Net::ThirtySevenSignals::Highrise;
{
  $Net::ThirtySevenSignals::Highrise::VERSION = '0.03';
}

use 5.006;
use utf8;
use strict qw(vars subs);
no warnings;
use warnings qw(FATAL closed threads internal debugging pack malloc
                  portable prototype inplace io pipe unpack regexp
                  deprecated glob digit printf layer
                  reserved taint closure semicolon);
no warnings qw(exec newline unopened);

use Carp;
use LWP::UserAgent;
use URI;
use HTTP::Request;
use XML::Simple;
# use Log::Log4perl qw( get_logger );

# my $logger = get_logger();


my %data = (
    'people_list_all' =>
    {
	url => '/people.xml',
	return_key => 'person',
    },

    'person_get' =>
    {
	url => '/people/[P:id].xml',
    },


    tag_add =>{
	url => '/[P:subjectType]/[P:subjectID]/tags.xml',
	method => "POST",
	req => '[P:tagName]'
    },

    'person_create' =>
    {
	url => '/people.xml?reload=true',
	req => '

  [P:firstName]
  [P:lastName]
  [P:companyName]


    [% IF P:emailAddress %]


        [P:emailAddress]
        Work


    [% END %]


    [% IF P:workPhone %]


        [P:workPhone]
        Work


    [% END %]


'
    },

    'person_destroy' =>
    {
	method => "DELETE",
	url => '/people/[P:id].xml',
    },

    'people_list_by_criteria' =>
    {
	url => '/people/search.xml',
	return_key => 'person',
    },

    'tags_list_all' =>
    {
	url => '/tags.xml',
	return_key=>'tag',
    },


    'tags_list_for_subject' =>
    {
	url => '/[P:subjectType]/[P:subjectID]/tags.xml',
	required_params => [qw(subjectType subjectID )],
	return_key => 'tag',
    },

	    'create_page' =>
	    {
	     url => '/ws/pages/new',
	     req => '
  [S:token]

    [P:title]
    [P:description]

'
	    },
	    'show_page' =>
	    {
	     url => '/ws/page/[P:id]',
	     req => '
  [S:token]
'
	    },
	    'destroy_page' =>
	    {
	     url => '/ws/page/[P:id]/destroy',
	     req => '
  [S:token]
'
	    },
	    'update_title' =>
	    {
	     url => '/ws/page/[P:id]/update_title',
	     req => '
  [S:token]
  [P:title]
'
	    },
	    update_body =>
	    {
	     url => '/ws/page/[P:id]/update_body',
	     req => '
  [S:token]
  [P:description]
'
	    },
	    'duplicate_page' =>
	    {
	     url => '/ws/page/[P:id]/duplicate',
	     req => '
  [S:token]
'
	    },
	    'link_page' =>
	    {
	     url => '/ws/page/[P:to_page]/link',
	     req => '
  [S:token]
  [P:link_page]
'
	    },
	    'unlink_page' =>
	    {
	     url => '/ws/page/[P:from_page]/link',
	     req => '
  [S:token]
  [P:link_page]
'
	    },
	    'share_people' =>
	    {
	     url => '/ws/page/[P:id]/share',
	     req => '
  [S:token]

    [P:people]

'
	    },
	    'make_page_public' =>
	    {
	     url => '/ws/page/[P:id]/share',
	     req => '
  [S:token]

    [P:public]

'
	    },
	    'unshare_friend_page' =>
	    {
	     url => '/ws/page/[P:id]/unshare_friend_page',
	     req => '
  [S:token]
'
	    },
	    'email_page' =>
	    {
	     url => '/ws/page/[P:id]/email',
	     req => '
  [S:token]
'
	    },
	    'list_all_items' =>
	    {
	     url => '/ws/page/[P:page_id]/items/list',
	     req => '
  [S:token]
'
	    },
	    'create_item' =>
	    {
	     url => '/ws/page/[P:page_id]/items/add',
	     req => '
  [S:token]

    [P:item]

'
	    },
	    'update_item' =>
	    {
	     url => '/ws/page/[P:page_id]/items/update/[P:id]',
	     req => '
  [S:token]

    [P:item]

'
	    },
	    'toggle_item' =>
	    {
	     url => '/ws/page/[P:page_id]/items/toggle/[P:id]',
	     req => '
  [S:token]
'
	    },
	    'destroy_item' =>
	    {
	     url => '/ws/page/[P:page_id]/items/destroy/[P:id]',
	     req => '
  [S:token]
'
	    },
	    'move_item' =>
	    {
	     url => '/ws/page/[P:page_id]/items/move/[P:id]',
	     req => '
  [S:token]
  [P:direction]
'
	    },
	    'list_all_notes' =>
	    {
	     url => '/ws/page/[P:page_id]/notes/list',
	     req => '
  [S:token]
'
	    },
	    'create_note' =>
	    {
	     url => '/ws/page/[P:page_id]/notes/create',
	     req => '
  [S:token]

    [P:title]
    [P:body]

'
	    },
	    'update_note' =>
	    {
	     url => '/ws/page/[P:page_id]/notes/update/[P:id]',
	     req => '
  [S:token]

    [P:title]
    [P:body]

'
	    },
	    'destroy_note' =>
	    {
	     url => '/ws/page/[P:page_id]/notes/destroy/[P:id]',
	     req => '
  [S:token]
'
	    },
	    'get_tag_pages' =>
	    {
	     url => '/ws/tags/[P:page_id]',
	     req => '
  [S:token]
'
	    },
	    'set_page_tags' =>
	    {
	     url => '/ws/page/[P:page_id]/tags/tag',
	     req => '
  [S:token]
  [P:tags]
'
	    },
	    'upcoming_reminders' =>
	    {
	     url => '/ws/reminders',
	     req => '
  [S:token]
'
	    },
	    'create_reminder' =>
	    {
	     url => '/ws/reminders/create',
	     req => '
  [S:token]

    [P:content]
	[P:remind_at]

'
	    },
	    'update_reminder' =>
	    {
	     url => '/ws/reminders/update/[P:id]',
	     req => '
  [S:token]

    [P:content]
	[P:remind_at]

'
	    },
	    'destroy_reminder' =>
	    {
	     url => '/ws/reminders/destroy/[P:id]',
	     req => '
  [S:token]
'
	    },
	    'list_all_emails' =>
	    {
	     url => '/ws/page/[P:page_id]/emails/list',
	     req => '
  [S:token]
'
	    },
	    'show_email' =>
	    {
	     url => '/ws/page/[P:page_id]/emails/show/[P:id]',
	     req => '
  [S:token]
'
	    },
	    'destroy_email' =>
	    {
	     url => '/ws/page/[P:page_id]/emails/destroy/[P:id]',
	     req => '
  [S:token]
'
	    },
	    'export' =>
	    {
	     url => '/ws/account/export',
	     req => '
  [S:token]
'
	    },
	    'list_all_lists' =>
	    {
	     url => '/ws/page/[P:page_id]/lists/list',
	     req => '
  [S:token]
'
	    },
	    'list_this_list' =>
	    {
	     url => '/ws/page/[P:page_id]/items/list?list_id=[P:list_id]',
	     req => '
  [S:token]
'
	    },
	    'create_list' =>
	    {
	     url => '/ws/page/[P:page_id]/lists/add',
	     req => '
  [S:token]
    [P:title]
'
	    },
	    'update_list' =>
	    {
	     url => '/ws/page/[P:page_id]/lists/update/[P:list_id]',
	     req =>	'
  [S:token]

    [P:title]

'
	    },
	    'destroy_list' =>
	    {
	     url => '/ws/page/[P:page_id]/lists/destroy/[P:list_id]',
	     req => '
  [S:token]
'
	    },
	    'create_list_item' =>
	    {
	     url => '/ws/page/[P:page_id]/items/add?list_id=[P:list_id]',
	     req =>	'
  [S:token]

    [P:item]

'
	    },
	   );

=head1 METHODS

=head2 $hr = Net::ThirtySevenSignals::Highrise->new(token => $token, user => $user, [forcearray => 0], ssl => 0);

Creates a new Net::ThirtySevenSignals::Highrise object. All communication with the
Highrise server is made through this object.

Takes two mandatory arguments, your Highrise API token and your
Highrise username. Returns the new Net:Highrise object.

There is also an optional parameter, forcearray. This controls the
value of the C parameter that is used by C. The
default value is 1.

If the C parameter is provided, then communication will take
place over SSL.  This is required for Plus and Premium accounts.

=cut

sub new {
  my $class = shift;
  my %params = @_;

  my $self;
  $self->{debug} = $params{debug};
  $self->{token} = $params{token}
    || croak "No Highrise API token passed Net::ThirtySevenSignals::Highrise::new\n";
  $self->{user}  = $params{user}
    || croak "No Highrise API user passed Net::ThirtySevenSignals::Highrise::new\n";

  $self->{protocol} = $params{ssl} ? 'https' : 'http';

  $self->{forcearray} = $params{forcearray} || 1;

  my $ua = $self->{ua} = LWP::UserAgent->new;

  $ua->env_proxy;
  $ua->default_header('X-POST-DATA-FORMAT' => 'xml');

  $ua->credentials($self->{user} . ".highrisehq.com:443","Application", $self->{token}, 'X');
  $ua->credentials($self->{user} . ".highrisehq.com:80","Application", $self->{token}, 'X');
  if( $self->{debug}){
      $ua->add_handler("request_send",sub{warn(shift->dump);return });
      $ua->add_handler("response_done",sub{warn(shift->dump);return });
  }

  $self->{base_url} = "$self->{protocol}://$self->{user}.highrisehq.com";

  return bless $self, $class;
}

=head2 $pages = $hr->people_list_all([xml => 1]);

Get a list of all of your Highrise people. Returns a Perl data structure
unless the C parameter is true, in which case it returns the raw
XML as returned by the Highrise server.

=cut

sub people_list_all {
  my $self = shift;
  my %params = @_;

  my $req_data = $data{people_list_all};
  my $url = $self->{base_url} . $req_data->{url};

  my $req = HTTP::Request->new('GET', $url);

  my $structure =  $self->_call(%params, req => $req);
  return $structure if $params{xml};
  return $structure->{$req_data->{return_key}};
}



=head2 $people = $hr->people_list_by_criteria([xml => 1], city => 'Oakland',country=>'US'...);

Returns a collection of people that match the criteria passed
in. Available criteria are:

city
state
country
zip
phone
email

Returns an arrayref or undef
unless the C parameter is true, in which case it returns the raw
XML as returned by the Highrise server.

=cut

sub people_list_by_criteria{
  my $self = shift;
  my %params = @_;

  my $req_data = $data{people_list_by_criteria};
  my $url = $self->{base_url} . $req_data->{url};

  my $expandedURL = new URI($self->_expand($url, %params));
  my %criteria = ();
  for my $key (qw(city state country zip phone email)){
      $criteria{"criteria[$key]"} = $params{$key} if exists $params{$key};
  }
  $expandedURL->query_form(%criteria);
  my $req = HTTP::Request->new('GET', $expandedURL);

  my $structure =  $self->_call(%params, req => $req);
  return $structure if $params{xml};
  return $structure->{$req_data->{return_key}};
}


=head2 $tags = $hr->tags_list_all([xml => 1]);

Get a list of all of your Highrise tags. Returns a Perl data structure
unless the C parameter is true, in which case it returns the raw
XML as returned by the Highrise server.

=cut

sub tags_list_all {
  my $self = shift;
  my %params = @_;

  my $req_data = $data{tags_list_all};
  my $url = $self->{base_url} . $req_data->{url};

  my $req = HTTP::Request->new('GET', $url);

  my $structure =  $self->_call(%params, req => $req);
  return $structure if $params{xml};
  return $structure->{$req_data->{return_key}};

}

=head2 $tags = $hr->tags_list_for_subject([xml => 1]);

Get a list of all of your Highrise tags. Returns a Perl data structure
unless the C parameter is true, in which case it returns the raw
XML as returned by the Highrise server.

=cut

sub tags_list_for_subject {
  my $self = shift;
  my %params = @_;

  my $req_data = $data{tags_list_for_subject};
  if( $req_data->{required_params} ){
      for my $name (@{$req_data->{required_params}}){
	  die "missing required param $name" unless defined $params{$name};
      }

  }
  my $url = $self->{base_url} . $req_data->{url};
  my $expandedURL = $self->_expand($url, %params);

  my $req = HTTP::Request->new('GET', $expandedURL);

  my $structure =  $self->_call(%params, req => $req);
  return $structure if $params{xml};
  return $structure->{$req_data->{return_key}};
}



=head2 $pages = $hr->person_get(id=> 123455,
                                [xml => 1]);

Get a list of all of your Highrise people. Returns a Perl data structure
unless the C parameter is true, in which case it returns the raw
XML as returned by the Highrise server.

returns a $person hashref or die()s if the person does not exist;

=cut

sub person_get {
  my $self = shift;
  my %params = @_;

  my $req_data = $data{person_get};
  my $url = $self->{base_url} . $req_data->{url};
  my $expandedURL = $self->_expand($url, %params);
  my $req = HTTP::Request->new('GET', $expandedURL);

  return $self->_call(%params, req => $req);
}



=head2 $pages = $hr->person_create(
                                [xml => 1]);

Create a person
unless the C parameter is true, in which case it returns the raw
XML as returned by the Highrise server.
Pass in parameters with keys:
   firstName
   lastName
   companyName
   emailAddress
   emailAddress

=cut

sub person_create {
  my $self = shift;
  my %params = @_;

  my $req_data = $data{person_create};
  my $url = $self->{base_url} . $req_data->{url};
  my $expandedURL = $self->_expand($url, %params);
  warn "url = $url, expanded = $expandedURL" if $self->{debug};
  my $req = HTTP::Request->new('POST', $expandedURL);
  my %encodedParams = ();
  while (my ($key, $value)  = each %params){
      $value =~ s/&/&/g;
      $value =~ s/
      $value =~ s/>/>/g;
      $encodedParams{$key} = $value;
  }
  $req->content($self->_expand($req_data->{req}, %encodedParams));

  return $self->_call(%params, req => $req);
}


=head2 $pages = $hr->tag_add(  $subject, $subjectType, $tagName );

add a tag to an item.
$subject should be a perl structure returned from one of person_get, company_get etc.
$subjectType should be one of
   people

=cut

sub tag_add {
  my $self = shift;
  my ($subject, $subjectType, $tagName ) = @_;

  my $req_data = $data{tag_add};
  use Data::Dumper;
  warn "tag add.  Subject = ".Dumper($subject);
  my %params = ( subjectType => $subjectType,
		 tagName => $tagName,
		 subjectID => $subject->{id}[0]{content},
      );
  my $url = $self->{base_url} . $req_data->{url};

  my $expandedURL = $self->_expand($url, %params);
  my $req = HTTP::Request->new('POST', $expandedURL);
  my %encodedParams = ();
  while (my ($key, $value)  = each %params){
      $value =~ s/&/&/g;
      $value =~ s/
      $value =~ s/>/>/g;
      $encodedParams{$key} = $value;
  }
  $req->content($self->_expand($req_data->{req}, %encodedParams));

  return $self->_call(%params, req => $req);
}


=head2 $pages = $hr->person_destroy();

Destroy a person.  either returns undef or die()s.

Pass in parameters with keys:
   id => the personid to be destroyed
=cut

sub person_destroy {
  my $self = shift;
  my %params = @_;

  my $req_data = $data{person_destroy};
  my $url = $self->{base_url} . $req_data->{url};
  my $expandedURL = $self->_expand($url, %params);
  my $req = HTTP::Request->new($req_data->{method}, $expandedURL);

  if( $req_data->{req}){
      my %encodedParams = ();
      while (my ($key, $value)  = each %params){
	  $value =~ s/&/&/g;
	  $value =~ s/
	  $value =~ s/>/>/g;
	  $encodedParams{$key} = $value;
      }
      $req->content($self->_expand($req_data->{req}, %encodedParams));
  }

  $self->_call(%params, req => $req, xml=>1);
  return ;
}

=head2 $page = $hr->create_page(title => $title,
                                [description => $desc, xml => 1]);

Create a new Highrise page with the given title and (optional)
description. Returns a Perl data structure unless the C parameter is
true, in which case it returns the raw XML as returned by the Highrise server.

=cut

sub _call {
  my $self = shift;
  my %params = @_;

  my $resp = $self->{ua}->request($params{req});
  unless(  $resp->is_success){
      die "Request Failed: ".$resp->status_line."\t".$resp->content;
  }
  my $xml = $resp->content;
  if( $self->{debug}){
      print "received xml: $xml\n";
  }

  if ($params{xml}) {
    return $xml;
  } else {
    my $data = XMLin($xml, ForceArray => $self->{forcearray});
    return $data;
  }
}

sub _expand {
  my $self = shift;
  my $string = shift;
  my %params = @_;
  my $startTag = qr"\Q[%\E";
  my $endTag = "%]";
  $string =~ s{ $startTag \s* IF \s* P:(\w+) \s*  $endTag
             (.+?)
              $startTag \s*  END \s*  $endTag
          } {
	      my ($condParam, $ifClause ) = ($1,$2);
	      if( $params{$1} ){
		  $2;
	      }
	      else{
		  '';
	      }
          }sexg;

  $string =~ s/\[S:(\w+)]/$self->{$1}/g;
  $string =~ s/\[P:(\w+)]/$params{$1}/g;
  # warn "expanded is $string\n";
  return $string;
}




=head2 $url = $hr->person_url($personHash);

Create an URL pointing at a person page.

=cut

sub person_url{
    my $self = shift;
    my ($person) = @_;
    return sprintf ("http://%s.highrisehq.com/people/%d", $self->{user}, $person->{id}->[0]->{content});
}




=head1 TO DO

=over 4

=item *

Improve documentation (I know, it's shameful)

=item *

More tests

=back

=head1 AUTHOR

Danny Sadinoff [e-mail]

derived directly from Dave Cross's Net::Backpack

Please feel free to email me to tell me how you are using the module.

=head1 BUGS

the API is incomplete, to say the least.

Please report bugs by email to [e-mail]

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2005,2010, Dave Cross, Danny Sadinoff.  All Rights Reserved.

This script is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L, L

=cut



1;
__END__