APR-HTTP-Headers-Compat
7 results

 view release on metacpan or  search on metacpan

inc/MyBuilder.pm  view on Meta::CPAN 

package MyBuilder;

use base qw( Module::Build );

sub create_build_script {
  my ( $self, @args ) = @_;
  $self->_auto_mm;
  return $self->SUPER::create_build_script( @args );
}

sub _auto_mm {
  my $self = shift;
  my $mm   = $self->meta_merge;
  my @meta = qw( homepage bugtracker MailingList repository );
  for my $meta ( @meta ) {
    next if exists $mm->{resources}{$meta};
    my $auto = "_auto_$meta";
    next unless $self->can( $auto );
    my $av = $self->$auto();
    $mm->{resources}{$meta} = $av if defined $av;
  }
  $self->meta_merge( $mm );
}

sub _auto_repository {
  my $self = shift;
  if ( -d '.svn' ) {
    my $info = `svn info .`;
    return $1 if $info =~ /^URL:\s+(.+)$/m;
  }
  elsif ( -d '.git' ) {
    my $info = `git remote -v`;
    return unless $info =~ /^origin\s+(.+)$/m;
    my $url = $1;
    # Special case: patch up github URLs
    $url =~ s!^git\@github\.com:!git://github.com/!;
    return $url;
  }
  return;
}

sub _auto_bugtracker {
  'http://rt.cpan.org/NoAuth/Bugs.html?Dist=' . shift->dist_name;
}

sub ACTION_testauthor {
  my $self = shift;
  $self->test_files( 'xt/author' );
  $self->ACTION_test;
}

sub ACTION_critic {
  exec qw( perlcritic -1 -q -profile perlcriticrc lib/ ), glob 't/*.t';
}

sub ACTION_tags {
  exec(
    qw(
     ctags -f tags --recurse --totals
     --exclude=blib
     --exclude=.svn
     --exclude='*~'
     --languages=Perl
     t/ lib/
     )
  );
}

sub ACTION_tidy {
  my $self = shift;

  my @extra = qw( Build.PL );

  my %found_files = map { %$_ } $self->find_pm_files,
   $self->_find_file_by_type( 'pm', 't' ),
   $self->_find_file_by_type( 'pm', 'inc' ),
   $self->_find_file_by_type( 't',  't' );

  my @files = ( keys %found_files,

lib/APR/HTTP/Headers/Compat.pm  view on Meta::CPAN 

  my $h = APR::HTTP::Headers::Compat->new( $table );

Optionally header initialisers may be passed:

  my $h = APR::HTTP::Headers::Compat->new( $table,
    'Content-type' => 'text/plain'
  );

=cut

sub new {
  my ( $class, $table ) = ( shift, shift );
  my %self = %{ $class->SUPER::new( @_ ) };
  tie %self, 'APR::HTTP::Headers::Compat::MagicHash', $table, %self;
  return bless \%self, $class;
}

sub _magic { tied %{ shift() } }

=head2 C<< clone >>

Clone this object. The clone is a regular L<HTTP::Headers> object rather
than an C<APR::HTTP::Headers::Compat>.

=cut

sub clone { bless { %{ shift() } }, 'HTTP::Headers' }

=head2 C<< table >>

Get the underlying L<APR::Table> object. Changes made in either the
table or the wrapper are reflected immediately in the other.

=cut

sub table { shift->_magic->table }

=head2 C<< remove_content_headers >>

This will remove all the header fields used to describe the content of a
message. All header field names prefixed with Content- falls into this
category, as well as Allow, Expires and Last-Modified. RFC 2616 denote
these fields as Entity Header Fields.

The return value is a new C<HTTP::Headers> object that contains the
removed headers only. Note that the returned object is I<not> an
C<APR::HTTP::Headers::Compat>.

=cut

sub remove_content_headers {
  my $self = shift;

  return $self->SUPER::remove_content_headers( @_ )
   unless defined wantarray;

  # This gets nasty. We downbless ourself to be an HTTP::Headers so that
  # when HTTP::Headers->remove_content_headers does
  #
  #   my $c = ref( $self )->new
  #

lib/APR/HTTP/Headers/Compat/MagicArray.pm  view on Meta::CPAN 


use strict;
use warnings;

=head1 NAME

APR::HTTP::Headers::Compat::MagicArray - magic array for multivalue headers

=cut

sub TIEARRAY {
  my ( $class, $fld, $magic, @vals ) = @_;
  return bless {
    a => \@vals,
    f => $fld,
    m => $magic,
  }, $class;
}

sub FETCH {
  my ( $self, $key ) = @_;
  return $self->{a}[$key];
}

# Sync the table with our state

sub _sync {
  my $self = shift;
  my ( $table, $fld, @vals )
   = ( $self->{m}->table, $self->{f}, @{ $self->{a} } );
  $table->set( $fld, shift @vals );
  $table->add( $fld, $_ ) for @vals;
}

sub STORE {
  my ( $self, $key, $value ) = @_;
  $self->{a}[$key] = $value;
  $self->_sync;
}

sub FETCHSIZE { scalar @{ shift->{a} } }
sub STORESIZE { }

sub CLEAR {
  my $self = shift;
  $self->{a} = [];
  $self->_sync;
}

sub PUSH {
  my ( $self, @list ) = @_;
  push @{ $self->{a} }, @list;
  $self->_sync;
}

sub POP {
  my $self = shift;
  my $val  = pop @{ $self->{a} };
  $self->_sync;
  return $val;
}

sub SHIFT {
  my $self = shift;
  my $val  = shift @{ $self->{a} };
  $self->_sync;
  return $val;
}

sub UNSHIFT {
  my ( $self, @list ) = @_;
  unshift @{ $self->{a} }, @list;
  $self->_sync;
}

sub SPLICE {
  my ( $self, $offset, $length, @list ) = @_;
  splice @{ $self->{a} }, $offset, $length, @list;
  $self->_sync;
}

sub EXISTS {
  my ( $self, $key ) = @_;
  return $key < @{ $self->{a} };
}

sub EXTEND  { }
sub DESTROY { }
sub UNTIE   { }

1;

# vim:ts=2:sw=2:sts=2:et:ft=perl

lib/APR/HTTP/Headers/Compat/MagicHash.pm  view on Meta::CPAN 

use Carp qw( confess );
use HTTP::Headers;
use Storable qw( dclone );

=head1 NAME

APR::HTTP::Headers::Compat::MagicHash - Tie a hash to an APR::Table

=cut

sub TIEHASH {
  my ( $class, $table, %args ) = @_;

  my $self = bless { table => $table }, $class;

  while ( my ( $k, $v ) = each %args ) {
    $self->STORE( $k, $v );
  }

  return $self;
}

=head2 C<< table >>

Get the table object.

=cut

sub table { shift->{table} }

sub _nicename {
  my ( $self, @names ) = @_;

  my $hdr    = HTTP::Headers->new( map { $_ => 1 } @names );
  my @nice   = $hdr->header_field_names;
  my %lookup = map { lc $_ => $_ } @nice;
  my @r = map { $lookup{$_} or confess "No mapping for $_" } @names;
  return wantarray ? @r : $r[0];
}

sub _nicefor {
  my ( $self, $name ) = @_;
  return $1 if $name =~ /^:(.+)/;
  return $self->{namemap}{$name} ||= $self->_nicename( $name );
}

sub FETCH {
  my ( $self, $key ) = @_;
  my $nkey = $self->_nicefor( $key );
  my @vals = $self->table->get( $nkey );
  return $vals[0] if @vals < 2;
  tie my @r, 'APR::HTTP::Headers::Compat::MagicArray', $nkey, $self,
   @vals;
  return \@r;
  #  return $self->{hash}{$nkey};
}

sub STORE {
  my ( $self, $key, $value ) = @_;
  my $nkey = $self->_nicefor( $key );
  $self->{rmap}{$nkey} = $key;

  my $table = $self->table;
  my @vals = 'ARRAY' eq ref $value ? @$value : $value;
  $table->set( $nkey, shift @vals );
  $table->add( $nkey, $_ ) for @vals;
  $self->_changed;
}

sub DELETE {
  my ( $self, $key ) = @_;
  my $nkey = $self->_nicefor( $key );
  my $rv   = $self->FETCH( $key );
  $self->table->unset( $nkey );
  $self->_changed;
  return $rv;
}

sub CLEAR {
  my ( $self ) = @_;
  $self->table->clear;
  $self->_changed;
}

sub EXISTS {
  my ( $self, $key ) = @_;
  my %fld = map { $_ => 1 } $self->_keys;
  return exists $fld{$key};
}

sub _mkkeys {
  my $self = shift;
  my @k    = ();
  my $rm   = $self->{rmap};
  my %seen = ();
  $self->table->do(
    sub {
      my ( $k, $v ) = @_;
      my $kk = defined $rm->{$k} ? $rm->{$k} : lc $k;
      push @k, $kk unless $seen{$kk}++;
    } );
  return \@k;
}

sub _keys {
  my $self = shift;
  return @{ $self->{keys} ||= $self->_mkkeys };
}

sub _changed {
  my $self = shift;
  delete $self->{keys};
}

sub FIRSTKEY {
  my ( $self ) = @_;
  $self->{pos} = 0;
  return ( $self->_keys )[0];
}

sub NEXTKEY {
  my ( $self, $lastkey ) = @_;
  my @keys = $self->_keys;
  unless ( $keys[ $self->{pos} ] eq $lastkey ) {
    my $nk = scalar @{ $self->{keys} };
    for my $i ( 0 .. $nk ) {
      if ( $keys[$i] eq $lastkey ) {
        $self->{pos} = $i;
        last;
      }
    }
  }
  return $keys[ ++$self->{pos} ];
}

sub SCALAR {
  my ( $self ) = @_;
  return scalar $self->_keys;
}

sub DESTROY {
  my ( $self ) = @_;
  #    use Data::Dumper;
  #    print STDERR "# ", Dumper($self);
  #  print STDERR "# <<<\n";
  #  $self->table->do(
  #    sub {
  #      my ( $k, $v ) = @_;
  #      print STDERR "# $k => $v\n";
  #    } );
  #  print STDERR "# >>>\n";
}

sub UNTIE { }

1;

# vim:ts=2:sw=2:sts=2:et:ft=perl

t/basic.t  view on Meta::CPAN 

{
  my $table = APR::Table::make( $Pool, 1 );
  ok my $h = APR::HTTP::Headers::Compat->new( $table ), 'new';
  $table->set( Foo => 'bar' );
  is $h->header( 'Foo' ), 'bar', 'alter table';
  $table->add( Foo => 'baz' );
  is_deeply [ $h->header( 'Foo' ) ], [ 'bar', 'baz' ],
   'alter table again';
}

sub tcont {
  my $table = shift;
  my @cont  = ();
  $table->do(
    sub {
      my ( $k, $v ) = @_;
      push @cont, $k, $v;
    } );
  return @cont;
}

# vim:ts=2:sw=2:et:ft=perl

t/compat/base/headers-etag.t  view on Meta::CPAN 

use strict;
use Test::More tests => 4;

use APR::Pool;
use APR::Table;
use APR::HTTP::Headers::Compat;
use HTTP::Headers::ETag;

my $Pool = APR::Pool->new;

sub mk(@) {
  my $table = APR::Table::make( $Pool, 10 );
  return APR::HTTP::Headers::Compat->new( $table, @_ );
}

my $h = mk;

$h->etag( "tag1" );
is( $h->etag, qq("tag1") );

$h->etag( "w/tag2" );

t/compat/base/headers.t  view on Meta::CPAN 

#!perl -w

use strict;

use Test::More tests => 163;
use APR::Pool;
use APR::Table;
use APR::HTTP::Headers::Compat;

my ( $h, $h2 );
sub j { join( "|", @_ ) }

my $Pool = APR::Pool->new;

sub mk(@) {
  my $table = APR::Table::make( $Pool, 10 );
  return APR::HTTP::Headers::Compat->new( $table, @_ );
}

$h = mk;
ok( $h );
is( ref( $h ),     "APR::HTTP::Headers::Compat" );
is( $h->as_string, "" );

$h = mk(

t/compat/base/headers.t  view on Meta::CPAN 

$h = mk(
  etag         => 1,
  foo          => [ 2, 3 ],
  content_type => "text/plain"
);
is( $h->header_field_names,      3 );
is( j( $h->header_field_names ), "ETag|Content-Type|Foo" );

{
  my @tmp;
  $h->scan( sub { push( @tmp, @_ ) } );
  is( j( @tmp ), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3" );

  @tmp = ();
  eval {
    $h->scan( sub { push( @tmp, @_ ); die if $_[0] eq "Content-Type" }
    );
  };
  ok( $@ );
  is( j( @tmp ), "ETag|1|Content-Type|text/plain" );

  @tmp = ();
  $h->scan( sub { push( @tmp, @_ ) } );
  is( j( @tmp ), "ETag|1|Content-Type|text/plain|Foo|2|Foo|3" );
}

# CONVENIENCE METHODS

$h = mk;
is( $h->date,                    undef );
is( $h->date( time ),            undef );
is( j( $h->header_field_names ), "Date" );
ok( $h->header( "Date" ) =~ /^[A-Z][a-z][a-z], \d\d .* GMT$/ );

t/compat/base/headers.t  view on Meta::CPAN 

@accept = $h->header( "accept" );
is( @accept, 1 );

# Check order of headers, but first remove this one
$h2->remove_header( 'mime_version' );

# and add this general header
$h2->header( Connection => 'close' );

my @x = ();
$h2->scan( sub { push( @x, shift ); } );
is( join( ";", @x ),
  "Connection;Accept;Accept;Accept;Content-Type;MY-Header" );

# Check headers with embedded newlines:
$h = mk(
  a => "foo\n\n",
  b => "foo\nbar",
  c => "foo\n\nbar\n\n",
  d => "foo\n\tbar",
  e => "foo\n  bar  ",



( run in 0.280 second using v1.01-cache-2.11-cpan-4d50c553e7e )