lib/Net/XRC/Response.pm

   1 package Net::XRC::Response;
   2
   3 use strict;
   4 use vars qw($AUTOLOAD);
   5
   6 my %exception = (
   7     1 => 'PROTOCOL',
   8     2 => 'UNKNOWN_COMMAND',
   9     4 => 'IO',
  10     5 => 'AUTHENTICATION_FAILURE',
  11     6 => 'SYSTEM_FAILURE',
  12     7 => 'PERMISSION_DENIED',
  13     8 => 'ARGUMENT_TYPE_MISMATCH',
  14    10 => 'UNKNOWN_TYPE',
  15    11 => 'SYNTAX',
  16    13 => 'SERIALIZE',
  17   200 => 'INVALID_ARGUMENT',
  18   201 => 'EMAIL_SERVICE_ALREADY_SETUP',
  19   202 => 'WEBMAIL_HOSTNAME_NOT_READY',
  20   203 => 'EMAIL_DOMAIN_NAME_NOT_READY',
  21   204 => 'WEBMAIL_HOSTNAME_TAKEN',
  22   205 => 'EMAIL_DOMAIN_NAME_TAKEN',
  23   206 => 'ACCOUNT_NAME_TAKEN',
  24   207 => 'CLIENT_DOES_NOT_EXIST',
  25   208 => 'INVALID_PASSWORD',
  26   209 => 'INVALID_ADDRESS',
  27   210  => 'EMAIL_SERVICE_NOT_READY',
  28   211 => 'INVALID_WEBMAIL_HOSTNAME',
  29   212 => 'INVALID_EMAIL_DOMAIN',
  30   213 => 'USER_DOES_NOT_EXIST',
  31   214 => 'INVALID_ACCOUNT_NAME',
  32   215 => 'OFFER_NOT_AVAILABLE',
  33   216 => 'ALIAS_DOES_NOT_EXIST',
  34   217 => 'USER_NO_MAILBOX',
  35   218 => 'EMAIL_SERVICE_NOT_FOUND',
  36   219 => 'ACCOUNT_NOT_SUSPENDED',
  37 );
  38
  39 my %exception_long = (
  40     1 => 'EOF while reading metadata, '.
  41          'a metadata line exceeded 8192 bytes, '.
  42          'missing a required metadata key-value pair, '.
  43          'metadata value malformed, or '.
  44          'missing method name and/or method arguments.',
  45     2 => 'The method name does not match a known method.',
  46     4 => 'IO error or premature EOF while parsing method arguments',
  47     5 => 'Credentials offered in metadata are not valid.',
  48     6 => 'An internal error in the XRC server. Everyone.net is automatically notified.',
  49     7 => 'The caller does not have necessary rights.',
  50     8 => 'One or more of the method arguments was not of the correct type, or the number of arguments to the method was incorrect.',
  51    10 => 'The name of a complex type is not known.',
  52    11 => 'An error in the format of the XRC request.',
  53    13 => 'A value of a complex type was of the wrong type or failed to meet the requirements of the type specification.',
  54   200 => 'An argument to a method did not meet the requirements of the specification.',
  55   201 => 'An attempt was made to setup an email service for a client that already has an email service.',
  56   202 => 'The webmail hostname is not properly configured. See DNS Requirements.',
  57   203 => 'The email domain is not properly configured. See DNS Requirements.',
  58   204 => 'The webmail hostname is in use by another client.',
  59   205 => 'The email domain is in use by another client.',
  60   206 => 'The username or alias name is in use.',
  61   207 => 'An operation was attempted on a client that cannot be found.',
  62   208 => 'The password is not valid. See Name Restrictions.',
  63   209 => 'An email address was not of legal form.',
  64   210 => 'The MX records of the email service have not been validated.',
  65   211 => 'The webmail hostname is not valid. See Name Restrictions.',
  66   212 => 'The email domain is not valid. See Name Restrictions.',
  67   213 => 'An operation was attempted on a user that cannot be found.',
  68   214 => 'The username or alias name is not valid. See Name Restrictions.',
  69   215 => 'The distributor attempted to apply an offer to a user or client that does not exist, applies to the wrong beneficiary, or does not belong to the distributor.',
  70   216 => 'An operation was attempted on an alias that cannot be found.',
  71   217 => 'The user does not have a mailbox.',
  72   218 => 'The client does not have an email service.',
  73   219 => 'The user mailbox cannot be purged because the user account is not in suspended mode.',
  74 );
  75
  76 =head1 NAME
  77
  78 Net::XRC::Response - XRC response object
  79
  80 =head1 SYNOPSIS
  81
  82   my $response = $xrc->some_method( $and, $args );
  83
  84   #response meta-data
  85   my $server = $response->server;
  86   my $timestamp = $response->server;
  87
  88   if ( $response->is_success ) {
  89
  90     my $content = $response->content;
  91     #...
  92
  93   } else {
  94
  95     my $status = $response->status; #error code
  96     my $error = $response->error; #error message
  97     #...
  98   }
  99
 100 =head1 DESCRIPTION
 101
 102 The "Net::XRC::Response" class represents XRC responses.
 103
 104 =cut
 105
 106 sub new {
 107   my $proto = shift;
 108   my $class = ref($proto) || $proto;
 109   my $self = {};
 110   bless($self, $class);
 111
 112   my $data = shift;
 113
 114   while ( $data =~ s/^(\w+):\s*(.*)$//m ) { #metadata
 115     warn "response metadata: $1 => $2\n"
 116       if $Net::XRC::DEBUG;
 117     $self->{$1} = $2;
 118   }
 119
 120   $self->{'content'} = $self->decode(\$data)
 121     if $self->is_success;
 122
 123   $self;
 124 }
 125
 126 sub is_success {
 127   my $self = shift;
 128   ! $self->{'status'};
 129 }
 130
 131 sub error {
 132   my $self = shift;
 133   $exception{ $self->{'status'} }. ': '. $exception_long{ $self->{'status'} }.
 134   ' - '. $self->{'errorDescription'};
 135 }
 136
 137 sub AUTOLOAD {
 138   my $self = shift;
 139   $AUTOLOAD =~ s/.*://;
 140   $self->{$AUTOLOAD};
 141 }
 142 #sub content { $self->{'content'}; }
 143 #sub status { $self->{'status'}; }
 144 #sub errorDescription { $self->{'errorDescription'}; }
 145 #sub server { $self->{'server'}; }
 146 #sub timestamp { $self->{'timestamp'}; }
 147
 148 sub decode {
 149   my( $self, $s ) = @_;
 150
 151   warn "starting to parse response: ". $$s
 152     if $Net::XRC::DEBUG > 1;
 153
 154   $$s =~ s/^[\s\n]+//g; #trim leading newlines and whitespace
 155
 156   if ( $$s =~ /^[\-\d]/ ) { #int
 157     $$s =~ s/^(\-?\d+)// and $1
 158       or die "can't parse (int) response: ". $$s. "\n";
 159   } elsif ( $$s =~ /^"/ ) { #string
 160     $$s =~  s/^"(([^"\\]|\\"|\\\\)+)"//
 161       or die "can't parse (string) response: ". $$s. "\n";
 162     my $str = $1;
 163     $str =~ s(\\")(")g;
 164     $str =~ s(\\\\)(\\)g;
 165     $str;
 166   } elsif ( $$s =~ /^\/[TF]/ ) { #boolean
 167     $$s =~ s/^\/([TF])//
 168       or die "can't parse (bool) response: ". $$s. "\n";
 169     $1 eq 'T' ? 1 : 0;
 170   } elsif ( $$s =~ s/^\/NULL// ) { #NULL
 171     undef;
 172   } elsif ( $$s =~ /^\{/ ) { #bytes
 173     $$s =~ s/^\{(\d+)\}//
 174       or die "can't parse (bytes) response: ". $$s. "\n";
 175     substr($$s, 0, $1, '');
 176   } elsif ( $$s =~ /^\(/ ) { #list
 177     $$s =~ s/^\([\s\n]*//
 178       or die "can't parse (list) reponse: ". $$s. "\n";
 179     my @list = ();
 180     until ( $$s =~ s/^[\s\n]*\)// ) {
 181       push @list, $self->decode($s);
 182       die "unterminated list\n" if $s =~ /^[\s\n]*$/;
 183     }
 184     \@list;
 185   } elsif ( $$s =~ /^:/ ) { #complex
 186     $$s =~ s/^:(\w+)[\s\n]*//
 187       or die "can't parse (complex) response: ". $$s. "\n";
 188     my %hash = ( '_type' => $1 );
 189     until ( $$s =~ s/^[\s\n]*\)// ) {
 190       $$s =~ s/^[\s\n]*(\w+)//
 191         or die "can't parse ($hash{_type}) response: ". $$s. "\n";
 192       $hash{$1} = $self->decode($s);
 193       die "unterminated $hash{_type}\n" if $s =~ /^[\s\n]*$/;
 194     }
 195     \%hash;
 196   } else {
 197     die "can't parse response: ". $$s. "\n";
 198   }
 199
 200 }
 201
 202 =head1 BUGS
 203
 204 Needs better documentation.
 205
 206 =head1 SEE ALSO
 207
 208 L<Net::XRC>,
 209 Everyone.net XRC Remote API documentation (XRC-1.0.5.html or later)
 210
 211 =head1 AUTHOR
 212
 213 Ivan Kohler E<lt>ivan-xrc@420.amE<gt>
 214
 215 =head1 COPYRIGHT AND LICENSE
 216
 217 Copyright (C) 2005 Ivan Kohler
 218
 219 This library is free software; you can redistribute it and/or modify
 220 it under the same terms as Perl itself.
 221
 222 =cut
 223
 224 1;