1package JSON::RPC::Legacy::Procedure; 2 3# 4# http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html 5# 6 7$JSON::RPC::Legacy::Procedure::VERSION = '0.90'; 8 9use strict; 10use attributes; 11use Carp (); 12 13my $Procedure = {}; 14 15 16sub check { $Procedure->{$_[0]} ? attributes::get($_[1]) : {}; } 17 18 19sub FETCH_CODE_ATTRIBUTES { 20 my ($pkg, $code) = @_; 21 my $procedure = $Procedure->{$pkg}{$code} || { return_type => undef, argument_type => undef }; 22 23 return { 24 return_type => $procedure->{return_type}, 25 argument_type => $procedure->{argument_type}, 26 }; 27} 28 29 30sub MODIFY_CODE_ATTRIBUTES { 31 my ($pkg, $code, $attr) = @_; 32 my ($ret_type, $args); 33 34 if ($attr =~ /^([A-Z][a-z]+)(?:\(\s*([^)]*)\s*\))?$/) { 35 $ret_type = $1 if (defined $1); 36 $args = $2 if (defined $2); 37 } 38 39 unless ($ret_type =~ /^Private|Public|Arr|Obj|Bit|Bool|Num|Str|Nil|None/) { 40 Carp::croak("Invalid type '$attr'. Specify 'Parivate' or 'Public' or One of JSONRPC Return Types."); 41 } 42 43 if ($ret_type ne 'Private' and defined $args) { 44 $Procedure->{$pkg}{$code}{argument_type} = _parse_argument_type($args); 45 } 46 47 $Procedure->{$pkg}{$code}{return_type} = $ret_type; 48 49 return; 50} 51 52 53 54sub _parse_argument_type { 55 my $text = shift; 56 57 my $declaration; 58 my $pos; 59 my $name; 60 61 $text =~ /^([,: a-zA-Z0-9]*)?$/; 62 63 unless ( defined($declaration = $1) ) { 64 Carp::croak("Invalid argument type."); 65 } 66 67 my @args = split/\s*,\s*/, $declaration; 68 69 my $i = 0; 70 71 $pos = []; 72 $name = {}; 73 74 for my $arg (@args) { 75 if ($arg =~ /([_0-9a-zA-Z]+)(?::([a-z]+))?/) { 76 push @$pos, $1; 77 $name->{$1} = $2; 78 } 79 } 80 81 return { 82 position => $pos, 83 names => $name, 84 }; 85} 86 87 88 891; 90__END__ 91 92=pod 93 94 95=head1 NAME 96 97JSON::RPC::Legacy::Procedure - JSON-RPC Service attributes 98 99=head1 SYNOPSIS 100 101 package MyApp; 102 103 use base ('JSON::RPC::Legacy::Procedure'); 104 105 sub sum : Public { 106 my ($s, @arg) = @_; 107 return $arg[0] + $arg[1]; 108 } 109 110 # or 111 112 sub sum : Public(a, b) { 113 my ($s, $obj) = @_; 114 return $obj->{a} + $obj->{b}; 115 } 116 117 # or 118 119 sub sum : Number(a:num, b:num) { 120 my ($s, $obj) = @_; 121 return $obj->{a} + $obj->{b}; 122 } 123 124 # private method can't be called by clients 125 126 sub _foobar : Private { 127 # ... 128 } 129 130 131=head1 DESCRIPTION 132 133Using this module, you can write a subroutine with a special attribute. 134 135 136Currently, in below attributes, only Public and Private are available. 137Others are same as Public. 138 139=over 140 141=item Public 142 143Means that a client can call this procedure. 144 145=item Private 146 147Means that a client can't call this procedure. 148 149=item Arr 150 151Means that its return values is an array object. 152 153=item Obj 154 155Means that its return values is a member object. 156 157=item Bit 158 159=item Bool 160 161Means that a return values is a C<true> or C<false>. 162 163 164=item Num 165 166Means that its return values is a number. 167 168=item Str 169 170Means that its return values is a string. 171 172=item Nil 173 174=item None 175 176Means that its return values is a C<null>. 177 178=back 179 180 181=head1 TODO 182 183=over 184 185=item Auto Service Description 186 187 188=item Type check 189 190=back 191 192=head1 SEE ALSO 193 194L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html> 195 196 197=head1 AUTHOR 198 199Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> 200 201 202=head1 COPYRIGHT AND LICENSE 203 204Copyright 2007 by Makamaka Hannyaharamitu 205 206This library is free software; you can redistribute it and/or modify 207it under the same terms as Perl itself. 208 209 210=cut 211