1package Net::Riak::Role::REST::Link; 2{ 3 $Net::Riak::Role::REST::Link::VERSION = '0.1702'; 4} 5use Moose::Role; 6use Net::Riak::Link; 7use Net::Riak::Bucket; 8 9sub _populate_links { 10 my ($self, $object, $links) = @_; 11 12 for my $link (split(',', $links)) { 13 if ($link 14 =~ /\<\/([^\/]+)\/([^\/]+)\/([^\/]+)\>; ?riaktag=\"([^\']+)\"/) 15 { 16 my $bucket = _uri_decode($2); 17 my $key = _uri_decode($3); 18 my $tag = _uri_decode($4); 19 my $l = Net::Riak::Link->new( 20 bucket => Net::Riak::Bucket->new( 21 name => $bucket, 22 client => $self 23 ), 24 key => $key, 25 tag => $tag 26 ); 27 $object->add_link($l); 28 } 29 } 30} 31 32sub _uri_decode { 33 my $str = shift; 34 $str =~ s/%([a-fA-F0-9]{2,2})/chr(hex($1))/eg; 35 return $str; 36} 37 38sub _links_to_header { 39 my ($self, $object) = @_; 40 join(', ', map { $self->link_to_header($_) } $object->links); 41} 42 43sub link_to_header { 44 my ($self, $link) = @_; 45 46 my $link_header = ''; 47 $link_header .= '</'; 48 $link_header .= $self->prefix . '/'; 49 $link_header .= $link->bucket->name . '/'; 50 $link_header .= $link->key . '>; riaktag="'; 51 $link_header .= $link->tag . '"'; 52 return $link_header; 53} 54 551; 56 57__END__ 58 59=pod 60 61=head1 NAME 62 63Net::Riak::Role::REST::Link 64 65=head1 VERSION 66 67version 0.1702 68 69=head1 AUTHOR 70 71franck cuny <franck@lumberjaph.net>, robin edwards <robin.ge@gmail.com> 72 73=head1 COPYRIGHT AND LICENSE 74 75This software is copyright (c) 2013 by linkfluence. 76 77This is free software; you can redistribute it and/or modify it under 78the same terms as the Perl 5 programming language system itself. 79 80=cut 81