Web-ID-1.922/0000755000076400007640000000000012063103672010662 5ustar taitaiWeb-ID-1.922/inc/0000755000076400007640000000000012063103671011432 5ustar taitaiWeb-ID-1.922/inc/YAML/0000755000076400007640000000000012063103671012174 5ustar taitaiWeb-ID-1.922/inc/YAML/Tiny.pm0000644000076400007640000003534412063103574013470 0ustar taitai#line 1 package YAML::Tiny; use strict; # UTF Support? sub HAVE_UTF8 () { $] >= 5.007003 } BEGIN { if ( HAVE_UTF8 ) { # The string eval helps hide this from Test::MinimumVersion eval "require utf8;"; die "Failed to load UTF-8 support" if $@; } # Class structure require 5.004; require Exporter; require Carp; $YAML::Tiny::VERSION = '1.51'; # $YAML::Tiny::VERSION = eval $YAML::Tiny::VERSION; @YAML::Tiny::ISA = qw{ Exporter }; @YAML::Tiny::EXPORT = qw{ Load Dump }; @YAML::Tiny::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; # Error storage $YAML::Tiny::errstr = ''; } # The character class of all characters we need to escape # NOTE: Inlined, since it's only used once # my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]'; # Printed form of the unprintable characters in the lowest range # of ASCII characters, listed by ASCII ordinal position. my @UNPRINTABLE = qw( z x01 x02 x03 x04 x05 x06 a x08 t n v f r x0e x0f x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1a e x1c x1d x1e x1f ); # Printable characters for escapes my %UNESCAPES = ( z => "\x00", a => "\x07", t => "\x09", n => "\x0a", v => "\x0b", f => "\x0c", r => "\x0d", e => "\x1b", '\\' => '\\', ); # Special magic boolean words my %QUOTE = map { $_ => 1 } qw{ null Null NULL y Y yes Yes YES n N no No NO true True TRUE false False FALSE on On ON off Off OFF }; ##################################################################### # Implementation # Create an empty YAML::Tiny object sub new { my $class = shift; bless [ @_ ], $class; } # Create an object from a file sub read { my $class = ref $_[0] ? ref shift : shift; # Check the file my $file = shift or return $class->_error( 'You did not specify a file name' ); return $class->_error( "File '$file' does not exist" ) unless -e $file; return $class->_error( "'$file' is a directory, not a file" ) unless -f _; return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; # Slurp in the file local $/ = undef; local *CFG; unless ( open(CFG, $file) ) { return $class->_error("Failed to open file '$file': $!"); } my $contents = ; unless ( close(CFG) ) { return $class->_error("Failed to close file '$file': $!"); } $class->read_string( $contents ); } # Create an object from a string sub read_string { my $class = ref $_[0] ? ref shift : shift; my $self = bless [], $class; my $string = $_[0]; eval { unless ( defined $string ) { die \"Did not provide a string to load"; } # Byte order marks # NOTE: Keeping this here to educate maintainers # my %BOM = ( # "\357\273\277" => 'UTF-8', # "\376\377" => 'UTF-16BE', # "\377\376" => 'UTF-16LE', # "\377\376\0\0" => 'UTF-32LE' # "\0\0\376\377" => 'UTF-32BE', # ); if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) { die \"Stream has a non UTF-8 BOM"; } else { # Strip UTF-8 bom if found, we'll just ignore it $string =~ s/^\357\273\277//; } # Try to decode as utf8 utf8::decode($string) if HAVE_UTF8; # Check for some special cases return $self unless length $string; unless ( $string =~ /[\012\015]+\z/ ) { die \"Stream does not end with newline character"; } # Split the file into lines my @lines = grep { ! /^\s*(?:\#.*)?\z/ } split /(?:\015{1,2}\012|\015|\012)/, $string; # Strip the initial YAML header @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; # A nibbling parser while ( @lines ) { # Do we have a document header? if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { # Handle scalar documents shift @lines; if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { push @$self, $self->_read_scalar( "$1", [ undef ], \@lines ); next; } } if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { # A naked document push @$self, undef; while ( @lines and $lines[0] !~ /^---/ ) { shift @lines; } } elsif ( $lines[0] =~ /^\s*\-/ ) { # An array at the root my $document = [ ]; push @$self, $document; $self->_read_array( $document, [ 0 ], \@lines ); } elsif ( $lines[0] =~ /^(\s*)\S/ ) { # A hash at the root my $document = { }; push @$self, $document; $self->_read_hash( $document, [ length($1) ], \@lines ); } else { die \"YAML::Tiny failed to classify the line '$lines[0]'"; } } }; if ( ref $@ eq 'SCALAR' ) { return $self->_error(${$@}); } elsif ( $@ ) { require Carp; Carp::croak($@); } return $self; } # Deparse a scalar string to the actual scalar sub _read_scalar { my ($self, $string, $indent, $lines) = @_; # Trim trailing whitespace $string =~ s/\s*\z//; # Explitic null/undef return undef if $string eq '~'; # Single quote if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) { return '' unless defined $1; $string = $1; $string =~ s/\'\'/\'/g; return $string; } # Double quote. # The commented out form is simpler, but overloaded the Perl regex # engine due to recursion and backtracking problems on strings # larger than 32,000ish characters. Keep it for reference purposes. # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) { if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) { # Reusing the variable is a little ugly, # but avoids a new variable and a string copy. $string = $1; $string =~ s/\\"/"/g; $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex; return $string; } # Special cases if ( $string =~ /^[\'\"!&]/ ) { die \"YAML::Tiny does not support a feature in line '$string'"; } return {} if $string =~ /^{}(?:\s+\#.*)?\z/; return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; # Regular unquoted string if ( $string !~ /^[>|]/ ) { if ( $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or $string =~ /:(?:\s|$)/ ) { die \"YAML::Tiny found illegal characters in plain scalar: '$string'"; } $string =~ s/\s+#.*\z//; return $string; } # Error die \"YAML::Tiny failed to find multi-line scalar content" unless @$lines; # Check the indent depth $lines->[0] =~ /^(\s*)/; $indent->[-1] = length("$1"); if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { die \"YAML::Tiny found bad indenting in line '$lines->[0]'"; } # Pull the lines my @multiline = (); while ( @$lines ) { $lines->[0] =~ /^(\s*)/; last unless length($1) >= $indent->[-1]; push @multiline, substr(shift(@$lines), length($1)); } my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; return join( $j, @multiline ) . $t; } # Parse an array sub _read_array { my ($self, $array, $indent, $lines) = @_; while ( @$lines ) { # Check for a new document if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { while ( @$lines and $lines->[0] !~ /^---/ ) { shift @$lines; } return 1; } # Check the indent level $lines->[0] =~ /^(\s*)/; if ( length($1) < $indent->[-1] ) { return 1; } elsif ( length($1) > $indent->[-1] ) { die \"YAML::Tiny found bad indenting in line '$lines->[0]'"; } if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { # Inline nested hash my $indent2 = length("$1"); $lines->[0] =~ s/-/ /; push @$array, { }; $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { # Array entry with a value shift @$lines; push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines ); } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { shift @$lines; unless ( @$lines ) { push @$array, undef; return 1; } if ( $lines->[0] =~ /^(\s*)\-/ ) { my $indent2 = length("$1"); if ( $indent->[-1] == $indent2 ) { # Null array entry push @$array, undef; } else { # Naked indenter push @$array, [ ]; $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines ); } } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { push @$array, { }; $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines ); } else { die \"YAML::Tiny failed to classify line '$lines->[0]'"; } } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { # This is probably a structure like the following... # --- # foo: # - list # bar: value # # ... so lets return and let the hash parser handle it return 1; } else { die \"YAML::Tiny failed to classify line '$lines->[0]'"; } } return 1; } # Parse an array sub _read_hash { my ($self, $hash, $indent, $lines) = @_; while ( @$lines ) { # Check for a new document if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { while ( @$lines and $lines->[0] !~ /^---/ ) { shift @$lines; } return 1; } # Check the indent level $lines->[0] =~ /^(\s*)/; if ( length($1) < $indent->[-1] ) { return 1; } elsif ( length($1) > $indent->[-1] ) { die \"YAML::Tiny found bad indenting in line '$lines->[0]'"; } # Get the key unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) { if ( $lines->[0] =~ /^\s*[?\'\"]/ ) { die \"YAML::Tiny does not support a feature in line '$lines->[0]'"; } die \"YAML::Tiny failed to classify line '$lines->[0]'"; } my $key = $1; # Do we have a value? if ( length $lines->[0] ) { # Yes $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines ); } else { # An indent shift @$lines; unless ( @$lines ) { $hash->{$key} = undef; return 1; } if ( $lines->[0] =~ /^(\s*)-/ ) { $hash->{$key} = []; $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines ); } elsif ( $lines->[0] =~ /^(\s*)./ ) { my $indent2 = length("$1"); if ( $indent->[-1] >= $indent2 ) { # Null hash entry $hash->{$key} = undef; } else { $hash->{$key} = {}; $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); } } } } return 1; } # Save an object to a file sub write { my $self = shift; my $file = shift or return $self->_error('No file name provided'); # Write it to the file open( CFG, '>' . $file ) or return $self->_error( "Failed to open file '$file' for writing: $!" ); print CFG $self->write_string; close CFG; return 1; } # Save an object to a string sub write_string { my $self = shift; return '' unless @$self; # Iterate over the documents my $indent = 0; my @lines = (); foreach my $cursor ( @$self ) { push @lines, '---'; # An empty document if ( ! defined $cursor ) { # Do nothing # A scalar document } elsif ( ! ref $cursor ) { $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent ); # A list at the root } elsif ( ref $cursor eq 'ARRAY' ) { unless ( @$cursor ) { $lines[-1] .= ' []'; next; } push @lines, $self->_write_array( $cursor, $indent, {} ); # A hash at the root } elsif ( ref $cursor eq 'HASH' ) { unless ( %$cursor ) { $lines[-1] .= ' {}'; next; } push @lines, $self->_write_hash( $cursor, $indent, {} ); } else { Carp::croak("Cannot serialize " . ref($cursor)); } } join '', map { "$_\n" } @lines; } sub _write_scalar { my $string = $_[1]; return '~' unless defined $string; return "''" unless length $string; if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) { $string =~ s/\\/\\\\/g; $string =~ s/"/\\"/g; $string =~ s/\n/\\n/g; $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; return qq|"$string"|; } if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) { return "'$string'"; } return $string; } sub _write_array { my ($self, $array, $indent, $seen) = @_; if ( $seen->{refaddr($array)}++ ) { die "YAML::Tiny does not support circular references"; } my @lines = (); foreach my $el ( @$array ) { my $line = (' ' x $indent) . '-'; my $type = ref $el; if ( ! $type ) { $line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); push @lines, $line; } elsif ( $type eq 'ARRAY' ) { if ( @$el ) { push @lines, $line; push @lines, $self->_write_array( $el, $indent + 1, $seen ); } else { $line .= ' []'; push @lines, $line; } } elsif ( $type eq 'HASH' ) { if ( keys %$el ) { push @lines, $line; push @lines, $self->_write_hash( $el, $indent + 1, $seen ); } else { $line .= ' {}'; push @lines, $line; } } else { die "YAML::Tiny does not support $type references"; } } @lines; } sub _write_hash { my ($self, $hash, $indent, $seen) = @_; if ( $seen->{refaddr($hash)}++ ) { die "YAML::Tiny does not support circular references"; } my @lines = (); foreach my $name ( sort keys %$hash ) { my $el = $hash->{$name}; my $line = (' ' x $indent) . "$name:"; my $type = ref $el; if ( ! $type ) { $line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); push @lines, $line; } elsif ( $type eq 'ARRAY' ) { if ( @$el ) { push @lines, $line; push @lines, $self->_write_array( $el, $indent + 1, $seen ); } else { $line .= ' []'; push @lines, $line; } } elsif ( $type eq 'HASH' ) { if ( keys %$el ) { push @lines, $line; push @lines, $self->_write_hash( $el, $indent + 1, $seen ); } else { $line .= ' {}'; push @lines, $line; } } else { die "YAML::Tiny does not support $type references"; } } @lines; } # Set error sub _error { $YAML::Tiny::errstr = $_[1]; undef; } # Retrieve error sub errstr { $YAML::Tiny::errstr; } ##################################################################### # YAML Compatibility sub Dump { YAML::Tiny->new(@_)->write_string; } sub Load { my $self = YAML::Tiny->read_string(@_); unless ( $self ) { Carp::croak("Failed to load YAML document from string"); } if ( wantarray ) { return @$self; } else { # To match YAML.pm, return the last document return $self->[-1]; } } BEGIN { *freeze = *Dump; *thaw = *Load; } sub DumpFile { my $file = shift; YAML::Tiny->new(@_)->write($file); } sub LoadFile { my $self = YAML::Tiny->read($_[0]); unless ( $self ) { Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'"); } if ( wantarray ) { return @$self; } else { # Return only the last document to match YAML.pm, return $self->[-1]; } } ##################################################################### # Use Scalar::Util if possible, otherwise emulate it BEGIN { local $@; eval { require Scalar::Util; }; my $v = eval("$Scalar::Util::VERSION") || 0; if ( $@ or $v < 1.18 ) { eval <<'END_PERL'; # Scalar::Util failed to load or too old sub refaddr { my $pkg = ref($_[0]) or return undef; if ( !! UNIVERSAL::can($_[0], 'can') ) { bless $_[0], 'Scalar::Util::Fake'; } else { $pkg = undef; } "$_[0]" =~ /0x(\w+)/; my $i = do { local $^W; hex $1 }; bless $_[0], $pkg if defined $pkg; $i; } END_PERL } else { *refaddr = *Scalar::Util::refaddr; } } 1; __END__ #line 1175 Web-ID-1.922/inc/Scalar/0000755000076400007640000000000012063103671012637 5ustar taitaiWeb-ID-1.922/inc/Scalar/Util.pm0000644000076400007640000000210512063103574014112 0ustar taitai#line 1 # Scalar::Util.pm # # Copyright (c) 1997-2007 Graham Barr . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package Scalar::Util; use strict; require Exporter; require List::Util; # List::Util loads the XS our @ISA = qw(Exporter); our @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); our $VERSION = "1.25"; $VERSION = eval $VERSION; our @EXPORT_FAIL; unless (defined &weaken) { push @EXPORT_FAIL, qw(weaken); } unless (defined &isweak) { push @EXPORT_FAIL, qw(isweak isvstring); } unless (defined &isvstring) { push @EXPORT_FAIL, qw(isvstring); } sub export_fail { if (grep { /^(?:weaken|isweak)$/ } @_ ) { require Carp; Carp::croak("Weak references are not implemented in the version of perl"); } if (grep { /^isvstring$/ } @_ ) { require Carp; Carp::croak("Vstrings are not implemented in the version of perl"); } @_; } 1; __END__ #line 261 Web-ID-1.922/inc/unicore/0000755000076400007640000000000012063103671013076 5ustar taitaiWeb-ID-1.922/inc/unicore/Name.pm0000644000076400007640000002127312063103574014323 0ustar taitai#line 1 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! # This file is machine-generated by lib/unicore/mktables from the Unicode # database, Version 6.1.0. Any changes made here will be lost! # !!!!!!! INTERNAL PERL USE ONLY !!!!!!! # This file is for internal use by core Perl only. The format and even the # name or existence of this file are subject to change without notice. Don't # use it directly. package charnames; # This module contains machine-generated tables and code for the # algorithmically-determinable Unicode character names. The following # routines can be used to translate between name and code point and vice versa { # Closure # Matches legal code point. 4-6 hex numbers, If there are 6, the first # two must be 10; if there are 5, the first must not be a 0. Written this # way to decrease backtracking. The first regex allows the code point to # be at the end of a word, but to work properly, the word shouldn't end # with a valid hex character. The second one won't match a code point at # the end of a word, and doesn't have the run-on issue my $run_on_code_point_re = qr/(?^aax: (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b)/; my $code_point_re = qr/(?^aa:\b(?^aax: (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b))/; # In the following hash, the keys are the bases of names which includes # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The values # of each key is another hash which is used to get the low and high ends # for each range of code points that apply to the name. my %names_ending_in_code_point = ( 'CJK COMPATIBILITY IDEOGRAPH' => { 'high' => [ 64109, 64217, 195101, ], 'low' => [ 63744, 64112, 194560, ], }, 'CJK UNIFIED IDEOGRAPH' => { 'high' => [ 19893, 40908, 173782, 177972, 178205, ], 'low' => [ 13312, 19968, 131072, 173824, 177984, ], }, ); # The following hash is a copy of the previous one, except is for loose # matching, so each name has blanks and dashes squeezed out my %loose_names_ending_in_code_point = ( 'CJKCOMPATIBILITYIDEOGRAPH' => { 'high' => [ 64109, 64217, 195101, ], 'low' => [ 63744, 64112, 194560, ], }, 'CJKUNIFIEDIDEOGRAPH' => { 'high' => [ 19893, 40908, 173782, 177972, 178205, ], 'low' => [ 13312, 19968, 131072, 173824, 177984, ], }, ); # And the following array gives the inverse mapping from code points to # names. Lowest code points are first my @code_points_ending_in_code_point = ( { 'high' => 19893, 'low' => 13312, 'name' => 'CJK UNIFIED IDEOGRAPH', }, { 'high' => 40908, 'low' => 19968, 'name' => 'CJK UNIFIED IDEOGRAPH', }, { 'high' => 64109, 'low' => 63744, 'name' => 'CJK COMPATIBILITY IDEOGRAPH', }, { 'high' => 64217, 'low' => 64112, 'name' => 'CJK COMPATIBILITY IDEOGRAPH', }, { 'high' => 173782, 'low' => 131072, 'name' => 'CJK UNIFIED IDEOGRAPH', }, { 'high' => 177972, 'low' => 173824, 'name' => 'CJK UNIFIED IDEOGRAPH', }, { 'high' => 178205, 'low' => 177984, 'name' => 'CJK UNIFIED IDEOGRAPH', }, { 'high' => 195101, 'low' => 194560, 'name' => 'CJK COMPATIBILITY IDEOGRAPH', }, , ); # Convert from code point to Jamo short name for use in composing Hangul # syllable names my %Jamo = ( 4352 => 'G', 4353 => 'GG', 4354 => 'N', 4355 => 'D', 4356 => 'DD', 4357 => 'R', 4358 => 'M', 4359 => 'B', 4360 => 'BB', 4361 => 'S', 4362 => 'SS', 4363 => '', 4364 => 'J', 4365 => 'JJ', 4366 => 'C', 4367 => 'K', 4368 => 'T', 4369 => 'P', 4370 => 'H', 4449 => 'A', 4450 => 'AE', 4451 => 'YA', 4452 => 'YAE', 4453 => 'EO', 4454 => 'E', 4455 => 'YEO', 4456 => 'YE', 4457 => 'O', 4458 => 'WA', 4459 => 'WAE', 4460 => 'OE', 4461 => 'YO', 4462 => 'U', 4463 => 'WEO', 4464 => 'WE', 4465 => 'WI', 4466 => 'YU', 4467 => 'EU', 4468 => 'YI', 4469 => 'I', 4520 => 'G', 4521 => 'GG', 4522 => 'GS', 4523 => 'N', 4524 => 'NJ', 4525 => 'NH', 4526 => 'D', 4527 => 'L', 4528 => 'LG', 4529 => 'LM', 4530 => 'LB', 4531 => 'LS', 4532 => 'LT', 4533 => 'LP', 4534 => 'LH', 4535 => 'M', 4536 => 'B', 4537 => 'BS', 4538 => 'S', 4539 => 'SS', 4540 => 'NG', 4541 => 'J', 4542 => 'C', 4543 => 'K', 4544 => 'T', 4545 => 'P', 4546 => 'H', ); # Leading consonant (can be null) my %Jamo_L = ( '' => 11, 'B' => 7, 'BB' => 8, 'C' => 14, 'D' => 3, 'DD' => 4, 'G' => 0, 'GG' => 1, 'H' => 18, 'J' => 12, 'JJ' => 13, 'K' => 15, 'M' => 6, 'N' => 2, 'P' => 17, 'R' => 5, 'S' => 9, 'SS' => 10, 'T' => 16, ); # Vowel my %Jamo_V = ( 'A' => 0, 'AE' => 1, 'E' => 5, 'EO' => 4, 'EU' => 18, 'I' => 20, 'O' => 8, 'OE' => 11, 'U' => 13, 'WA' => 9, 'WAE' => 10, 'WE' => 15, 'WEO' => 14, 'WI' => 16, 'YA' => 2, 'YAE' => 3, 'YE' => 7, 'YEO' => 6, 'YI' => 19, 'YO' => 12, 'YU' => 17, ); # Optional trailing consonant my %Jamo_T = ( 'B' => 17, 'BS' => 18, 'C' => 23, 'D' => 7, 'G' => 1, 'GG' => 2, 'GS' => 3, 'H' => 27, 'J' => 22, 'K' => 24, 'L' => 8, 'LB' => 11, 'LG' => 9, 'LH' => 15, 'LM' => 10, 'LP' => 14, 'LS' => 12, 'LT' => 13, 'M' => 16, 'N' => 4, 'NG' => 21, 'NH' => 6, 'NJ' => 5, 'P' => 26, 'S' => 19, 'SS' => 20, 'T' => 25, ); # Computed re that splits up a Hangul name into LVT or LV syllables my $syllable_re = qr/(|B|BB|C|D|DD|G|GG|H|J|JJ|K|M|N|P|R|S|SS|T)(A|AE|E|EO|EU|I|O|OE|U|WA|WAE|WE|WEO|WI|YA|YAE|YE|YEO|YI|YO|YU)(B|BS|C|D|G|GG|GS|H|J|K|L|LB|LG|LH|LM|LP|LS|LT|M|N|NG|NH|NJ|P|S|SS|T)?/; my $HANGUL_SYLLABLE = "HANGUL SYLLABLE "; my $loose_HANGUL_SYLLABLE = "HANGULSYLLABLE"; # These constants names and values were taken from the Unicode standard, # version 5.1, section 3.12. They are used in conjunction with Hangul # syllables my $SBase = 0xAC00; my $LBase = 0x1100; my $VBase = 0x1161; my $TBase = 0x11A7; my $SCount = 11172; my $LCount = 19; my $VCount = 21; my $TCount = 28; my $NCount = $VCount * $TCount; sub name_to_code_point_special { my ($name, $loose) = @_; # Returns undef if not one of the specially handled names; otherwise # returns the code point equivalent to the input name # $loose is non-zero if to use loose matching, 'name' in that case # must be input as upper case with all blanks and dashes squeezed out. if ((! $loose && $name =~ s/$HANGUL_SYLLABLE//) || ($loose && $name =~ s/$loose_HANGUL_SYLLABLE//)) { return if $name !~ qr/^$syllable_re$/; my $L = $Jamo_L{$1}; my $V = $Jamo_V{$2}; my $T = (defined $3) ? $Jamo_T{$3} : 0; return ($L * $VCount + $V) * $TCount + $T + $SBase; } # Name must end in 'code_point' for this to handle. return if (($loose && $name !~ /^ (.*?) ($run_on_code_point_re) $/x) || (! $loose && $name !~ /^ (.*) ($code_point_re) $/x)); my $base = $1; my $code_point = CORE::hex $2; my $names_ref; if ($loose) { $names_ref = \%loose_names_ending_in_code_point; } else { return if $base !~ s/-$//; $names_ref = \%names_ending_in_code_point; } # Name must be one of the ones which has the code point in it. return if ! $names_ref->{$base}; # Look through the list of ranges that apply to this name to see if # the code point is in one of them. for (my $i = 0; $i < scalar @{$names_ref->{$base}{'low'}}; $i++) { return if $names_ref->{$base}{'low'}->[$i] > $code_point; next if $names_ref->{$base}{'high'}->[$i] < $code_point; # Here, the code point is in the range. return $code_point; } # Here, looked like the name had a code point number in it, but # did not match one of the valid ones. return; } sub code_point_to_name_special { my $code_point = shift; # Returns the name of a code point if algorithmically determinable; # undef if not # If in the Hangul range, calculate the name based on Unicode's # algorithm if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) { use integer; my $SIndex = $code_point - $SBase; my $L = $LBase + $SIndex / $NCount; my $V = $VBase + ($SIndex % $NCount) / $TCount; my $T = $TBase + $SIndex % $TCount; $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}"; $name .= $Jamo{$T} if $T != $TBase; return $name; } # Look through list of these code points for one in range. foreach my $hash (@code_points_ending_in_code_point) { return if $code_point < $hash->{'low'}; if ($code_point <= $hash->{'high'}) { return sprintf("%s-%04X", $hash->{'name'}, $code_point); } } return; # None found } } # End closure 1; Web-ID-1.922/inc/utf8.pm0000644000076400007640000000061512063103574012662 0ustar taitai#line 1 package utf8; $utf8::hint_bits = 0x00800000; our $VERSION = '1.09'; sub import { $^H |= $utf8::hint_bits; $enc{caller()} = $_[1] if $_[1]; } sub unimport { $^H &= ~$utf8::hint_bits; } sub AUTOLOAD { require "utf8_heavy.pl"; goto &$AUTOLOAD if defined &$AUTOLOAD; require Carp; Carp::croak("Undefined subroutine $AUTOLOAD called"); } 1; __END__ #line 214 Web-ID-1.922/inc/Module/0000755000076400007640000000000012063103671012657 5ustar taitaiWeb-ID-1.922/inc/Module/AutoInstall.pm0000644000076400007640000006216212063103603015456 0ustar taitai#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @installed; @installed = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1193 Web-ID-1.922/inc/Module/Package.pm0000644000076400007640000000311412063103605014544 0ustar taitai#line 1 ## # name: Module::Package # abstract: Postmodern Perl Module Packaging # author: Ingy döt Net # license: perl # copyright: 2011 # see: # - Module::Package::Plugin # - Module::Install::Package # - Module::Package::Tutorial package Module::Package; use 5.005; use strict; BEGIN { $Module::Package::VERSION = '0.30'; $inc::Module::Package::VERSION ||= $Module::Package::VERSION; @inc::Module::Package::ISA = __PACKAGE__; } sub import { my $class = shift; $INC{'inc/Module/Install.pm'} = __FILE__; unshift @INC, 'inc' unless $INC[0] eq 'inc'; eval "use Module::Install 1.01 (); 1" or $class->error($@); package main; Module::Install->import(); eval { module_package_internals_version_check($Module::Package::VERSION); module_package_internals_init(@_); }; if ($@) { $Module::Package::ERROR = $@; die $@; } } # XXX Remove this when things are stable. sub error { my ($class, $error) = @_; if (-e 'inc' and not -e 'inc/.author') { require Data::Dumper; $Data::Dumper::Sortkeys = 1; my $dump1 = Data::Dumper::Dumper(\%INC); my $dump2 = Data::Dumper::Dumper(\@INC); die <<"..."; This should not have happened. Hopefully this dump will explain the problem: inc::Module::Package: $inc::Module::Package::VERSION Module::Package: $Module::Package::VERSION inc::Module::Install: $inc::Module::Install::VERSION Module::Install: $Module::Install::VERSION Error: $error %INC: $dump1 \@INC: $dump2 ... } else { die $error; } } 1; Web-ID-1.922/inc/Module/Install/0000755000076400007640000000000012063103671014265 5ustar taitaiWeb-ID-1.922/inc/Module/Install/Fetch.pm0000644000076400007640000000462712063103604015661 0ustar taitai#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Web-ID-1.922/inc/Module/Install/AutoInstall.pm0000644000076400007640000000416212063103602017057 0ustar taitai#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; Web-ID-1.922/inc/Module/Install/Package.pm0000644000076400007640000002340512063103572016162 0ustar taitai#line 1 ## # name: Module::Install::Package # abstract: Module::Install support for Module::Package # author: Ingy döt Net # license: perl # copyright: 2011 # see: # - Module::Package # This module contains the Module::Package logic that must be available to # both the Author and the End User. Author-only logic goes in a # Module::Package::Plugin subclass. package Module::Install::Package; use strict; use Module::Install::Base; use vars qw'@ISA $VERSION'; @ISA = 'Module::Install::Base'; $VERSION = '0.30'; #-----------------------------------------------------------------------------# # XXX BOOTBUGHACK # This is here to try to get us out of Module-Package-0.11 cpantesters hell... # Remove this when the situation has blown over. sub pkg { *inc::Module::Package::VERSION = sub { $VERSION }; my $self = shift; $self->module_package_internals_init($@); } #-----------------------------------------------------------------------------# # We allow the author to specify key/value options after the plugin. These # options need to be available both at author time and install time. #-----------------------------------------------------------------------------# # OO accessor for command line options: sub package_options { @_>1?($_[0]->{package_options}=$_[1]):$_[0]->{package_options}} my $default_options = { deps_list => 1, install_bin => 1, install_share => 1, manifest_skip => 1, requires_from => 1, }; #-----------------------------------------------------------------------------# # Module::Install plugin directives. Use long, ugly names to not pollute the # Module::Install plugin namespace. These are only intended to be called from # Module::Package. #-----------------------------------------------------------------------------# # Module::Package starts off life as a normal call to this Module::Install # plugin directive: my $module_install_plugin; my $module_package_plugin; my $module_package_dist_plugin; # XXX ARGVHACK This @argv thing is a temporary fix for an ugly bug somewhere in the # Wikitext module usage. my @argv; sub module_package_internals_init { my $self = $module_install_plugin = shift; my ($plugin_spec, %options) = @_; $self->package_options({%$default_options, %options}); if ($module_install_plugin->is_admin) { $module_package_plugin = $self->_load_plugin($plugin_spec); $module_package_plugin->mi($module_install_plugin); $module_package_plugin->version_check($VERSION); } else { $module_package_dist_plugin = $self->_load_dist_plugin($plugin_spec); $module_package_dist_plugin->mi($module_install_plugin) if ref $module_package_dist_plugin; } # NOTE - This is the point in time where the body of Makefile.PL runs... return; sub INIT { return unless $module_install_plugin; return if $Module::Package::ERROR; eval { if ($module_install_plugin->is_admin) { $module_package_plugin->initial(); $module_package_plugin->main(); } else { $module_install_plugin->_initial(); $module_package_dist_plugin->_initial() if ref $module_package_dist_plugin; $module_install_plugin->_main(); $module_package_dist_plugin->_main() if ref $module_package_dist_plugin; } }; if ($@) { $Module::Package::ERROR = $@; die $@; } @argv = @ARGV; # XXX ARGVHACK } # If this Module::Install plugin was used (by Module::Package) then wrap # up any loose ends. This will get called after Makefile.PL has completed. sub END { @ARGV = @argv; # XXX ARGVHACK return unless $module_install_plugin; return if $Module::Package::ERROR; $module_package_plugin ? do { $module_package_plugin->final; $module_package_plugin->replicate_module_package; } : do { $module_install_plugin->_final; $module_package_dist_plugin->_final() if ref $module_package_dist_plugin; } } } # Module::Package, Module::Install::Package and Module::Package::Plugin # must all have the same version. Seems wise. sub module_package_internals_version_check { my ($self, $version) = @_; return if $version < 0.1800001; # XXX BOOTBUGHACK!! die <<"..." unless $version == $VERSION; Error! Something has gone awry: Module::Package version=$version is using Module::Install::Package version=$VERSION If you are the author of this module, try upgrading Module::Package. Otherwise, please notify the author of this error. ... } # Find and load the author side plugin: sub _load_plugin { my ($self, $spec, $namespace) = @_; $spec ||= ''; $namespace ||= 'Module::Package'; my $version = ''; $Module::Package::plugin_version = 0; if ($spec =~ s/\s+(\S+)\s*//) { $version = $1; $Module::Package::plugin_version = $version; } my ($module, $plugin) = not($spec) ? ('Plugin', "Plugin::basic") : ($spec =~ /^\w(\w|::)*$/) ? ($spec, $spec) : ($spec =~ /^:(\w+)$/) ? ('Plugin', "Plugin::$1") : ($spec =~ /^(\S*\w):(\w+)$/) ? ($1, "$1::$2") : die "$spec is invalid"; $module = "${namespace}::${module}"; $plugin = "${namespace}::${plugin}"; eval "use $module $version (); 1" or die $@; return $plugin->new(); } # Find and load the user side plugin: sub _load_dist_plugin { my ($self, $spec, $namespace) = @_; $spec ||= ''; $namespace ||= 'Module::Package::Dist'; my $r = eval { $self->_load_plugin($spec, $namespace); }; return $r if ref $r; return; } #-----------------------------------------------------------------------------# # These are the user side analogs to the author side plugin API calls. # Prefix with '_' to not pollute Module::Install plugin space. #-----------------------------------------------------------------------------# sub _initial { my ($self) = @_; } sub _main { my ($self) = @_; } # NOTE These must match Module::Package::Plugin::final. sub _final { my ($self) = @_; $self->_all_from; $self->_requires_from; $self->_install_bin; $self->_install_share; $self->_WriteAll; } #-----------------------------------------------------------------------------# # This section is where all the useful code bits go. These bits are needed by # both Author and User side runs. #-----------------------------------------------------------------------------# my $all_from = 0; sub _all_from { my $self = shift; return if $all_from++; return if $self->name; my $file = shift || "$main::PM" or die "all_from has no file"; $self->all_from($file); } my $requires_from = 0; sub _requires_from { my $self = shift; return if $requires_from++; return unless $self->package_options->{requires_from}; my $file = shift || "$main::PM" or die "requires_from has no file"; $self->requires_from($main::PM) } my $install_bin = 0; sub _install_bin { my $self = shift; return if $install_bin++; return unless $self->package_options->{install_bin}; return unless -d 'bin'; my @bin; File::Find::find(sub { return unless -f $_; push @bin, $File::Find::name; }, 'bin'); $self->install_script($_) for @bin; } my $install_share = 0; sub _install_share { my $self = shift; return if $install_share++; return unless $self->package_options->{install_share}; return unless -d 'share'; $self->install_share; } my $WriteAll = 0; sub _WriteAll { my $self = shift; return if $WriteAll++; $self->WriteAll(@_); } # Base package for Module::Package plugin distributed components. package Module::Package::Dist; sub new { my ($class, %args) = @_; bless \%args, $class; } sub mi { @_ > 1 ? ($_[0]->{mi}=$_[1]) : $_[0]->{mi}; } sub _initial { my ($self) = @_; } sub _main { my ($self) = @_; } sub _final { my ($self) = @_; } 1; #-----------------------------------------------------------------------------# # Take a guess at the primary .pm and .pod files for 'all_from', and friends. # Put them in global magical vars in the main:: namespace. #-----------------------------------------------------------------------------# package Module::Package::PM; use overload '""' => sub { $_[0]->guess_pm unless @{$_[0]}; return $_[0]->[0]; }; sub set { $_[0]->[0] = $_[1] } sub guess_pm { my $pm = ''; my $self = shift; if (-e 'META.yml') { open META, 'META.yml' or die "Can't open 'META.yml' for input:\n$!"; my $meta = do { local $/; }; close META; $meta =~ /^module_name: (\S+)$/m or die "Can't get module_name from META.yml"; $pm = $1; $pm =~ s!::!/!g; $pm = "lib/$pm.pm"; } else { require File::Find; my @array = (); File::Find::find(sub { return unless /\.pm$/; my $name = $File::Find::name; my $num = ($name =~ s!/+!/!g); my $ary = $array[$num] ||= []; push @$ary, $name; }, 'lib'); shift @array while @array and not defined $array[0]; die "Can't guess main module" unless @array; (($pm) = sort @{$array[0]}) or die "Can't guess main module"; } my $pmc = $pm . 'c'; $pm = $pmc if -e $pmc; $self->set($pm); } $main::PM = bless [$main::PM ? ($main::PM) : ()], __PACKAGE__; package Module::Package::POD; use overload '""' => sub { return $_[0]->[0] if @{$_[0]}; (my $pod = "$main::PM") =~ s/\.pm/.pod/ or die "Module::Package's \$main::PM value should end in '.pm'"; return -e $pod ? $pod : ''; }; sub set { $_[0][0] = $_[1] } $main::POD = bless [$main::POD ? ($main::POD) : ()], __PACKAGE__; 1; Web-ID-1.922/inc/Module/Install/Win32.pm0000644000076400007640000000340312063103604015521 0ustar taitai#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Web-ID-1.922/inc/Module/Install/Makefile.pm0000644000076400007640000002743712063103576016361 0ustar taitai#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Web-ID-1.922/inc/Module/Install/Can.pm0000644000076400007640000000615712063103604015331 0ustar taitai#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Web-ID-1.922/inc/Module/Install/Base.pm0000644000076400007640000000214712063103572015501 0ustar taitai#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Web-ID-1.922/inc/Module/Install/WriteAll.pm0000644000076400007640000000237612063103604016352 0ustar taitai#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Web-ID-1.922/inc/Module/Install/Include.pm0000644000076400007640000000101512063103573016204 0ustar taitai#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Web-ID-1.922/inc/Module/Install/Metadata.pm0000644000076400007640000004327712063103572016360 0ustar taitai#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Web-ID-1.922/inc/Module/Install/AutoManifest.pm0000644000076400007640000000125712063103602017221 0ustar taitai#line 1 use strict; use warnings; package Module::Install::AutoManifest; use Module::Install::Base; BEGIN { our $VERSION = '0.003'; our $ISCORE = 1; our @ISA = qw(Module::Install::Base); } sub auto_manifest { my ($self) = @_; return unless $Module::Install::AUTHOR; die "auto_manifest requested, but no MANIFEST.SKIP exists\n" unless -e "MANIFEST.SKIP"; if (-e "MANIFEST") { unlink('MANIFEST') or die "Can't remove MANIFEST: $!"; } $self->postamble(<<"END"); create_distdir: manifest_clean manifest distclean :: manifest_clean manifest_clean: \t\$(RM_F) MANIFEST END } 1; __END__ #line 48 #line 131 1; # End of Module::Install::AutoManifest Web-ID-1.922/inc/Module/Install/TrustMetaYml.pm0000644000076400007640000000162212063103572017236 0ustar taitai#line 1 package Module::Install::TrustMetaYml; use 5.005; use strict; BEGIN { $Module::Install::TrustMetaYml::AUTHORITY = 'cpan:TOBYINK'; $Module::Install::TrustMetaYml::VERSION = '0.002'; } use base qw(Module::Install::Base); sub trust_meta_yml { my ($self, $where) = @_; $where ||= 'META.yml'; $self->perl_version('5.005') unless defined $self->perl_version; $self->include_deps('YAML::Tiny', 0); return $self if $self->is_admin; require YAML::Tiny; my $data = YAML::Tiny::LoadFile($where); $self->perl_version($data->{requires}{perl} || '5.005'); KEY: foreach my $key (qw(requires recommends build_requires)) { next KEY unless ref $data->{$key} eq 'HASH'; my %deps = %{$data->{$key}}; DEP: while (my ($pkg, $ver) = each %deps) { next if $pkg eq 'perl'; $self->$key($pkg, $ver); } } return $self; } *trust_meta_yaml = \&trust_meta_yml; 1; __END__ =encoding utf8 Web-ID-1.922/inc/Module/Install.pm0000644000076400007640000003013512063103553014624 0ustar taitai#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Web-ID-1.922/inc/Module/Package/0000755000076400007640000000000012063103671014212 5ustar taitaiWeb-ID-1.922/inc/Module/Package/Dist/0000755000076400007640000000000012063103671015115 5ustar taitaiWeb-ID-1.922/inc/Module/Package/Dist/RDF.pm0000644000076400007640000000204712063103576016075 0ustar taitai#line 1 package Module::Package::Dist::RDF; my $explanation = q< This is the component of Module::Package::RDF which gets bundled with the distribution. >; use 5.005; use strict; BEGIN { $Module::Package::Dist::RDF::AUTHORITY = 'cpan:TOBYINK'; $Module::Package::Dist::RDF::VERSION = '0.009'; @Module::Package::Dist::RDF::ISA = 'Module::Package::Dist'; } sub _main { my ($self) = @_; $self->mi->trust_meta_yml; $self->mi->auto_install; } { package Module::Package::Dist::RDF::standard; use 5.005; use strict; BEGIN { $Module::Package::Dist::RDF::standard::AUTHORITY = 'cpan:TOBYINK'; $Module::Package::Dist::RDF::standard::VERSION = '0.009'; @Module::Package::Dist::RDF::standard::ISA = 'Module::Package::Dist::RDF'; } } { package Module::Package::Dist::RDF::tobyink; use 5.005; use strict; BEGIN { $Module::Package::Dist::RDF::tobyink::AUTHORITY = 'cpan:TOBYINK'; $Module::Package::Dist::RDF::tobyink::VERSION = '0.009'; @Module::Package::Dist::RDF::tobyink::ISA = 'Module::Package::Dist::RDF'; } } 1; Web-ID-1.922/COPYRIGHT0000644000076400007640000001026612063103602012153 0ustar taitaiFormat: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Upstream-Name: Web-ID Upstream-Contact: Toby Inkster Source: https://metacpan.org/release/Web-ID Files: COPYRIGHT Copyright: None License: public-domain Comment: This file! Automatically generated. Files: inc/Module/Install.pm Copyright: Copyright 2002 - 2012 Brian Ingerson, Audrey Tang and Adam Kennedy. License: GPL-1.0+ or Artistic-1.0 Files: inc/Module/Install/Base.pm Copyright: Copyright 2003, 2004 by Audrey Tang . License: GPL-1.0+ or Artistic-1.0 Files: inc/Module/Install/Include.pm Copyright: Copyright 2002 - 2012 Brian Ingerson, Audrey Tang and Adam Kennedy. License: GPL-1.0+ or Artistic-1.0 Files: inc/Module/Install/Makefile.pm Copyright: Copyright 2002, 2003, 2004 Audrey Tang and Brian Ingerson. License: GPL-1.0+ or Artistic-1.0 Files: inc/Module/Install/Metadata.pm Copyright: Copyright 2002 - 2012 Brian Ingerson, Audrey Tang and Adam Kennedy. License: GPL-1.0+ or Artistic-1.0 Files: inc/Module/Install/Package.pm Copyright: Copyright (c) 2011. Ingy doet Net. License: GPL-1.0+ or Artistic-1.0 Files: inc/Module/Install/TrustMetaYml.pm Copyright: This software is copyright (c) 2011-2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: inc/Scalar/Util.pm Copyright: Copyright (c) 1997-2007 Graham Barr . All rights reserved. Copyright (c) 1999 Tuomas J. Lukka . All rights reserved. License: GPL-1.0+ or Artistic-1.0 Files: inc/YAML/Tiny.pm Copyright: Copyright 2006 - 2012 Adam Kennedy. License: GPL-1.0+ or Artistic-1.0 Files: inc/unicore/Name.pm Copyright: 1993-2012, Larry Wall and others License: GPL-1.0+ or Artistic-1.0 Files: inc/utf8.pm Copyright: 1993-2012, Larry Wall and others License: GPL-1.0+ or Artistic-1.0 Files: lib/Plack/Middleware/Auth/WebID.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/Certificate.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/Certificate/Generator.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/FAQ.pod Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/RSAKey.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/SAN.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/SAN/Email.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/SAN/URI.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/Types.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Web/ID/Util.pm Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: t/01mouse.t Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: t/02moose.t Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: t/03certificate.t Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: t/04webid.t Copyright: This software is copyright (c) 2012 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: Changes LICENSE MANIFEST.SKIP Makefile.PL README examples/certificate-generation.pl examples/certificate-parsing.pl examples/fingerpoint-test.pl examples/web-id-validation.pl inc/Module/Package/Dist/RDF.pm meta/changes.ttl meta/doap.ttl meta/makefile.ttl t/lib/Test/HTTP/Server.pm Copyright: Unknown License: Unknown License: GPL-1.0+ or Artistic-1.0 This software is copyright (c) 2012 by the copyright holder(s). This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Web-ID-1.922/t/0000755000076400007640000000000012063103671011124 5ustar taitaiWeb-ID-1.922/t/04webid.t0000644000076400007640000000646012062700053012551 0ustar taitai=head1 PURPOSE Performs as close to an end-to-end test as possible without an actual HTTPS server. Generates certificates for five dummy identities using L; creates FOAF profiles for them (using a mixture of Turtle and RDF/XML) and checks that their certificates can be validated against their profiles. Destroys one of the FOAF profiles and checks that the corresponding certificate no longer validates. Alters one of the FOAF profiles and checks that the corresponding certificate no longer validates. Tries its very best to clean up after itself. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use 5.010; use strict; use lib 'lib'; use lib 't/lib'; use File::Temp qw(); use Path::Class qw(); use Test::More; use Web::ID; use Web::ID::Certificate::Generator; # Attempt to silence openssl during test cases sub capture_merged (&;@); BEGIN { *capture_merged = eval { require Capture::Tiny } ? \&Capture::Tiny::capture_merged : sub (&;@) { my $code = shift; $code->() } } -x '/usr/bin/openssl' or plan skip_all => "/usr/bin/openssl not executable"; # They're unlikely to have /usr/bin/openssl anyway, but... $^O eq 'MSWin32' and plan skip_all => "This test will not run on MSWin32"; our @PEOPLE = qw(alice bob carol david eve); our %Certificates; my $tmpdir = Path::Class::Dir->new( File::Temp->newdir ); $tmpdir->mkpath; sub tmpfile { return $tmpdir->file(@_) if @_; return $tmpdir; } { package Test::HTTP::Server::Request; no strict 'refs'; for my $p (@::PEOPLE) { *$p = sub { if (-e main::tmpfile($p)) { shift->{out_headers}{content_type} = $p eq 'david' ? 'text/turtle' : 'application/rdf+xml'; ~~main::tmpfile($p)->slurp; } else { my $server = shift; $server->{out_code} = '404 Not Found'; $server->{out_headers}{content_type} = 'text/plain'; 'Not Found'; } } } } eval { require Test::HTTP::Server; 1; } or plan skip_all => "Could not use Test::HTTP::Server: $@"; plan tests => 12; my $server = Test::HTTP::Server->new(); my $baseuri = $server->uri; for my $p (@PEOPLE) { my $discard; my $rdf; my @captured = capture_merged { $Certificates{$p} = 'Web::ID::Certificate'->generate( passphrase => 'secret', subject_alt_names => [ Web::ID::SAN::URI->new(value => $baseuri.$p), ], subject_cn => ucfirst($p), rdf_output => \$rdf, cert_output => \$discard, )->pem }; isa_ok($rdf, 'RDF::Trine::Model', tmpfile($p).' $rdf'); RDF::Trine::Serializer -> new($p eq 'david' ? 'Turtle' : 'RDFXML') -> serialize_model_to_file(tmpfile($p)->openw, $rdf); } for my $p (@PEOPLE) { my $webid = Web::ID->new(certificate => $Certificates{$p}); ok($webid->valid, $webid->uri); } tmpfile('carol')->remove; # bye, bye my $carol = Web::ID->new(certificate => $Certificates{carol}); ok(!$carol->valid, 'bye, bye carol!'); do { (my $data = tmpfile('eve')->slurp) =~ s/exponent/component/g; my $fh = tmpfile('eve')->openw; print $fh $data; }; my $eve = Web::ID->new(certificate => $Certificates{eve}); ok(!$eve->valid, 'eve is evil!'); tmpfile()->rmtree; Web-ID-1.922/t/02moose.t0000644000076400007640000000073512062675435012615 0ustar taitai=head1 PURPOSE Check that Web::ID compiles. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use Test::More; #eval { require Moose; require MooseX::Types::Moose; 1 } # or plan skip_all => "need Moose"; plan tests => 1; use_ok('Web::ID'); Web-ID-1.922/t/lib/0000755000076400007640000000000012063103671011672 5ustar taitaiWeb-ID-1.922/t/lib/Test/0000755000076400007640000000000012063103671012611 5ustar taitaiWeb-ID-1.922/t/lib/Test/HTTP/0000755000076400007640000000000012063103671013370 5ustar taitaiWeb-ID-1.922/t/lib/Test/HTTP/Server.pm0000644000076400007640000001627411750316625015215 0ustar taitaipackage Test::HTTP::Server; # # 2011 (c) Przemysław Iskra # This program is free software, # you may distribute it under the same terms as Perl. # use strict; use warnings; use IO::Socket; use POSIX ":sys_wait_h"; our $VERSION = '0.03'; sub _open_socket { my $frompid = $$; $frompid %= 63 * 1024; $frompid += 63 * 1024 if $frompid < 1024; my $port = $ENV{HTTP_PORT} || $frompid; foreach ( 0..100 ) { my $socket = IO::Socket::INET->new( Proto => 'tcp', LocalPort => $port, Listen => 5, Reuse => 1, Blocking => 1, ); return ( $port, $socket ) if $socket; $port = 1024 + int rand 63 * 1024; } } sub new { my $class = shift; my ( $port, $socket ) = _open_socket() or die "Could not start HTTP server\n"; my $pid = fork; die "Could not fork\n" unless defined $pid; if ( $pid ) { my $self = { address => "127.0.0.1", port => $port, pid => $pid, }; return bless $self, $class; } else { $SIG{CHLD} = \&_sigchld; _main_loop( $socket, @_ ); exec "true"; die "Should not be here\n"; } } sub uri { my $self = shift; return "http://$self->{address}:$self->{port}/"; } sub port { my $self = shift; $self->{port}; } sub address { my $self = shift; if ( @_ ) { $self->{address} = shift; } $self->{address}; } sub _sigchld { my $kid; local $?; do { $kid = waitpid -1, WNOHANG; } while ( $kid > 0 ); } sub DESTROY { my $self = shift; my $done = 0; local $SIG{CHLD} = \&_sigchld; my $cnt = kill 15, $self->{pid}; return unless $cnt; foreach my $sig ( 15, 15, 15, 9, 9, 9 ) { $cnt = kill $sig, $self->{pid}; last unless $cnt; select undef, undef, undef, 0.1; } } sub _term { exec "true"; die "Should not be here\n"; } sub _main_loop { my $socket = shift; $SIG{TERM} = \&_term; for (;;) { my $client = $socket->accept() or redo; my $pid = fork; die "Could not fork\n" unless defined $pid; if ( $pid ) { close $client; } else { Test::HTTP::Server::Request->open( $client, @_ ); _term(); } } } package Test::HTTP::Server::Connection; BEGIN { eval { require URI::Escape; URI::Escape->import( qw(uri_unescape) ); }; if ( $@ ) { *uri_unescape = sub { local $_ = shift; s/%(..)/chr hex $1/eg; return $_; }; } } use constant DNAME => [qw(Sun Mon Tue Wed Thu Fri Sat)]; use constant MNAME => [qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)]; sub _http_time { my $self = shift; my @t = gmtime( shift || time ); return sprintf '%s, %02d %s %04d %02d:%02d:%02d GMT', DNAME->[ $t[6] ], $t[3], MNAME->[ $t[4] ], 1900+$t[5], $t[2], $t[1], $t[0]; } sub open { my $class = shift; my $socket = shift; open STDOUT, '>&', $socket; open STDIN, '<&', $socket; my $self = { version => "1.0", @_, socket => $socket, }; bless $self, $class; $self->process; } sub process { my $self = shift; $self->in_all; $self->out_all; close STDIN; close STDOUT; close $self->{socket}; } sub in_all { my $self = shift; $self->{request} = $self->in_request; $self->{headers} = $self->in_headers; if ( $self->{request}->[0] =~ /^(?:POST|PUT)/ ) { $self->{body} = $self->in_body; } else { delete $self->{body}; } } sub in_request { my $self = shift; local $/ = "\r\n"; $_ = ; $self->{head} = $_; chomp; return [ split /\s+/, $_ ]; } sub in_headers { my $self = shift; local $/ = "\r\n"; my @headers; while ( ) { $self->{head} .= $_; chomp; last unless length $_; s/(\S+):\s*//; my $header = $1; $header =~ tr/-/_/; push @headers, ( lc $header, $_ ); } return \@headers; } sub in_body { my $self = shift; my %headers = @{ $self->{headers} }; $_ = ""; my $len = $headers{content_length}; $len = 10 * 1024 * 1024 unless defined $len; read STDIN, $_, $len; return $_; } sub out_response { my $self = shift; my $code = shift; print "HTTP/$self->{version} $code\r\n"; } sub out_headers { my $self = shift; while ( my ( $name, $value ) = splice @_, 0, 2 ) { $name = join "-", map { ucfirst lc $_ } split /[_-]+/, $name; if ( ref $value ) { # must be an array foreach my $val ( @$value ) { print "$name: $val\r\n"; } } else { print "$name: $value\r\n"; } } } sub out_body { my $self = shift; my $body = shift; use bytes; my $len = length $body; print "Content-Length: $len\r\n"; print "\r\n"; print $body; } sub out_all { my $self = shift; my %default_headers = ( content_type => "text/plain", date => $self->_http_time, ); $self->{out_headers} = { %default_headers }; my $req = $self->{request}->[1]; $req =~ s#^/##; my @args = map { uri_unescape $_ } split m#/#, $req; my $func = shift @args; $func = "index" unless defined $func and length $func; my $body; eval { $body = $self->$func( @args ); }; if ( $@ ) { warn "Server error: $@\n"; $self->out_response( "404 Not Found" ); $self->out_headers( %default_headers ); $self->out_body( "Server error: $@\n" ); } elsif ( defined $body ) { $self->out_response( $self->{out_code} || "200 OK" ); $self->out_headers( %{ $self->{out_headers} } ); $self->out_body( $body ); } } # default handlers sub index { my $self = shift; my $body = "Available functions:\n"; $body .= ( join "", map "- $_\n", sort { $a cmp $b} grep { not __PACKAGE__->can( $_ ) } grep { Test::HTTP::Server::Request->can( $_ ) } keys %{Test::HTTP::Server::Request::} ) || "NONE\n"; return $body; } sub echo { my $self = shift; my $type = shift; my $body = ""; if ( not $type or $type eq "head" ) { $body .= $self->{head}; } if ( ( not $type or $type eq "body" ) and defined $self->{body} ) { $body .= $self->{body}; } return $body; } sub cookie { my $self = shift; my $num = shift || 1; my $template = shift || "test_cookie%n=true; expires=%date(+600); path=/"; my $expdate = sub { my $time = shift; $time += time if $time =~ m/^[+-]/; return $self->_http_time( $time ); }; my @cookies; foreach my $n ( 1..$num ) { $_ = $template; s/%n/$n/; s/%date\(\s*([+-]?\d+)\s*\)/$expdate->( $1 )/e; push @cookies, $_; } $self->{out_headers}->{set_cookie} = \@cookies; return "Sent $num cookies matching template:\n$template\n"; } sub repeat { my $self = shift; my $num = shift || 1024; my $pattern = shift || "="; return $pattern x $num; } package Test::HTTP::Server::Request; our @ISA = qw(Test::HTTP::Server::Connection); 1; __END__ =head1 NAME Test::HTTP::Server - simple forking http server =head1 SYNOPSIS my $server = Test::HTTP::Server->new(); client_get( $server->uri . "my_request" ); sub Test::HTTP::Server::Request::my_request { my $self = shift; return "foobar!\n" } =head1 DESCRIPTION This package provices a simple forking http server which can be used for testing http clients. =head1 DEFAULT METHODS =over =item index Lists user methods. =item echo / TYPE Returns whole request in the body. If TYPE is "head", only request head will be echoed, if TYPE is "body" (i.g. post requests) only body will be sent. system "wget", $server->uri . "echo/head"; =item cookie / REPEAT / PATTERN Sets a cookie. REPEAT is the number of cookies to be sent. PATTERN is the cookie pattern. system "wget", $server->uri . "cookie/3"; =item repeat / REPEAT / PATTERN Sends a pattern. system "wget", $server->uri . "repeat/2/foobar"; =back =cut Web-ID-1.922/t/01mouse.t0000644000076400007640000000063212062677207012615 0ustar taitai=head1 PURPOSE This test has been retired. Web::ID no longer uses Any::Moose/Mouse. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use Test::More skip_all => "eek! eek!"; Web-ID-1.922/t/03certificate.t0000644000076400007640000000725312062676040013751 0ustar taitai=head1 PURPOSE Tests that L is able to extract information from a PEM-encoded certificate. The majority of the tests are conducted on a certificate that I<< will expire on 2013-06-21T11:49:45 >> however, it is believed that the nature of these tests is such that they will continue to pass after the certificate has expired. (No tests should be relying on it being a timely certificate.) The situation may need reviewing in July 2013. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use Test::More tests => 18; use Web::ID::Certificate; my $cert = new_ok 'Web::ID::Certificate' => [pem => <not_before, '2009-06-22T11:49:45', 'certificate not_before correct', ); is( $cert->not_after, '2013-06-21T11:49:45', 'certificate not_after correct', ); ok( ! $cert->timely( $cert->not_before->clone->subtract(days => 1) ), 'not timely before not_before', ); ok( $cert->timely( $cert->not_before ), 'timely on not_before', ); ok( $cert->timely( $cert->not_before->clone->add(days => 1) ), 'timely after not_before', ); ok( $cert->timely( $cert->not_after ), 'timely on not_after', ); ok( ! $cert->timely( $cert->not_after->clone->add(days => 1) ), 'not timely after not_after', ); is( $cert->fingerprint, 'f4651a0cd4efc7301103a7dfec983244dd47b190', 'correct fingerprint', ); ok( $cert->exponent eq '65537', 'correct exponent' ); (my $modulus = <modulus eq $modulus, 'correct modulus' ); isa_ok( $cert->subject_alt_names->[$_], 'Web::ID::SAN', "SAN $_", ) for 0..2; isa_ok( $cert->subject_alt_names->[0], 'Web::ID::SAN::URI', "SAN 0", ); isa_ok( $cert->subject_alt_names->[$_], 'Web::ID::SAN::Email', "SAN $_", ) for 1..2; is( $cert->subject_alt_names->[0]->value, 'http://tobyinkster.co.uk/#i', 'SAN 0 correct value', ); Web-ID-1.922/README0000644000076400007640000001021512063103576011544 0ustar taitaiNAME Web::ID - implementation of WebID (a.k.a. FOAF+SSL) SYNOPSIS my $webid = Web::ID->new(certificate => $pem_encoded_x509); if ($webid->valid) { say "Authenticated as: ", $webid->uri; } DESCRIPTION WebID is a simple authentication protocol based on TLS (Transaction Layer Security, better known as Secure Socket Layer, SSL) and the Semantic Web. This module provides a Perl implementation for authenticating clients using WebID. For more information see the Web::ID::FAQ document. Bundled with this module are Plack::Middleware::Auth::WebID, a plugin for Plack to perform WebID authentication on HTTPS connections; and Web::ID::Certificate::Generator, a module that allows you to generate WebID-enabled certificates that can be installed into web browsers. Constructor "new" Standard Moose-style constructor. Attributes "certificate" A Web::ID::Certificate object representing and x509 certificate, though a PEM-encoded string will be coerced. This is usually the only attribute you want to pass to the constructor. Allow the others to be built automatically. "first_valid_san" Probably fairly uninteresting. This is the first subjectAltName value found in the certificate that could be successfully authenticated using Web::ID. An Web::ID::SAN object. "uri" The URI associated with the first valid SAN. A URI object. This is a URI you can use to identify the person, organisation or robotic poodle holding the certificate. "profile" Data about the certificate holder. An RDF::Trine::Model object. Their FOAF file (probably). "valid" Boolean. Methods "node" Returns the same as "uri", but as an RDF::Trine::Node object. "get(@predicates)" Queries the "profile" for triples of the form: $self->node $predicate $x . And returns literal and URI values for $x, as strings. $predicate should be an RDF::Trine::Node, or a string. If a string, it will be expanded using RDF::Trine::NamespaceMap, so you can do stuff like: my $name = $webid->get('foaf:name', 'rdfs:label'); my @mboxes = $webid->get('foaf:mbox'); BUGS Please report any bugs to . SEE ALSO Web::ID::FAQ. Web::ID::Certificate, Plack::Middleware::Auth::WebID. RDF::ACL provides an access control system that complements WebID. CGI::Auth::FOAF_SSL is the spiritual ancestor of this module though they share very little code, and have quite different APIs. General WebID information: , , , . Mailing list for general Perl RDF/SemWeb discussion and support: . AUTHOR Toby Inkster . THANKS Thanks to Kjetil Kjernsmo (cpan:KJETILK) for persuading me to port my old CGI-specific implementaton of this to Plack. Thanks Kjetil Kjernsmo (again), Florian Ragwitz (cpan:FLORA), and Jonas Smedegaard for help with testing and advice on dependencies. Thanks to Henry Story, Melvin Carvalho, Simon Reinhardt, Bruno Harbulot, Ian Jacobi and many others for developing WebID from a poorly thought out idea to a clever, yet simple and practical authentication protocol. Thanks to Gregory Williams (cpan:GWILLIAMS), Tatsuhiko Miyagawa (cpan:MIYAGAWA) and the Moose Cabal for providing really good platforms (RDF::Trine, Plack and Moose respectively) to build this on. COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/0000755000076400007640000000000012063103671011427 5ustar taitaiWeb-ID-1.922/lib/Web/0000755000076400007640000000000012063103671012144 5ustar taitaiWeb-ID-1.922/lib/Web/ID/0000755000076400007640000000000012063103671012440 5ustar taitaiWeb-ID-1.922/lib/Web/ID/Certificate/0000755000076400007640000000000012063103671014662 5ustar taitaiWeb-ID-1.922/lib/Web/ID/Certificate/Generator.pm0000644000076400007640000002115312062674743017164 0ustar taitaipackage Web::ID::Certificate::Generator; use 5.010; use utf8; BEGIN { $Web::ID::Certificate::Generator::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::Certificate::Generator::VERSION = '1.922'; } use MooseX::Types::Moose -all; use Moose::Util qw(apply_all_roles); use File::Temp qw(); use Path::Class qw(); use RDF::Trine qw(statement blank iri literal); use Web::ID::Certificate; use Web::ID::Types ':all'; use Web::ID::Util; use Moose::Role; use namespace::sweep; sub import { apply_all_roles('Web::ID::Certificate', __PACKAGE__); } sub _openssl_path { Path::Class::File->new( $^O eq 'Win32' ? 'c:\\openssl\\bin\\openssl.exe' : '/usr/bin/openssl' ) } sub generate { my ($class, %options) = @_; my $openssl = (delete $options{openssl_path}) // $class->_openssl_path; my $passphrase = (delete $options{passphrase}) or confess "need to provide passphrase option"; my $key_size = (delete $options{key_size}) // 1024; my $sans = (delete $options{subject_alt_names}) or confess "need to provide subject_alt_names option"; my $not_after = (delete $options{not_after}); my $dest = (delete $options{cert_output}) or confess "need to provide cert_output option"; my $rdf_sink = (delete $options{rdf_output}) or confess "need to provide rdf_output option"; my %subject = ( C => delete $options{subject_country}, ST => delete $options{subject_region}, L => delete $options{subject_locality}, O => delete $options{subject_org}, CN => delete $options{subject_cn}, ); confess "need to provide subject_cn option" unless $subject{CN}; confess "unsupported options: ".(join q(, ), sort keys %options) if %options; my $days = $not_after ? $not_after->delta_days( DateTime->now )->days : 365; my $tempdir = Path::Class::Dir->new( File::Temp->newdir ); $tempdir->mkpath; my $config = $tempdir->file('openssl.cnf')->openw; say $config $_ for q([req]), q(default_bits = 1024), q(default_keyfile = privkey.pem), q(distinguished_name = req_distinguished_name), q(x509_extensions = v3_ca), q(prompt = no), q(), q([v3_ca]); say $config q(subjectAltName = ) . join q(,), map { my $value = $_->value; my $type = { rfc822Name => 'email', uniformResourceIdentifier => 'URI', }->{ $_->type }; $type ? (join q(:), $type, $value) : (); } @$sans; say $config $_ for q(), q([req_distinguished_name]); foreach (qw(C ST L O CN)) { next unless (defined $subject{$_} and length $subject{$_}); say $config "$_ = ", $subject{$_}; } close $config; system( $openssl, "req", "-newkey" => "rsa:".$key_size, "-x509", "-days" => $days, "-config" => $tempdir->file('openssl.cnf'), "-out" => $tempdir->file('cert.pem'), "-keyout" => $tempdir->file('privkey.pem'), "-passout" => "pass:".$passphrase, ); system( $openssl, "pkcs12", "-export", "-in" => $tempdir->file('cert.pem'), "-inkey" => $tempdir->file('privkey.pem'), "-out" => $tempdir->file('cert.p12'), "-name" => sprintf('%s <%s>', ($subject{CN}//'Unnamed'), $sans->[0]->value), "-passin" => "pass:".$passphrase, "-passout" => "pass:".$passphrase, ); if (ref $dest eq 'SCALAR') { $$dest = $tempdir->file('cert.p12')->slurp; } elsif (ref $dest =~ m/^IO/) { my $p12 = $tempdir->file('cert.p12')->slurp; print $dest $p12; } else { my $p12 = $tempdir->file('cert.p12')->slurp; my $fh = Path::Class::File->new($dest)->openw; print $fh $p12; } my ($on_triple, $on_done) = (sub {}, sub {}); if (ref $rdf_sink eq 'SCALAR') { $$rdf_sink = RDF::Trine::Model->new; $on_triple = sub { $$rdf_sink->add_statement(statement(@_)) }; } elsif (blessed($rdf_sink) and $rdf_sink->isa('RDF::Trine::Model')) { $on_triple = sub { $rdf_sink->add_statement(statement(@_)) }; } else { my $model = RDF::Trine::Model->new; my $fh = Path::Class::File->new($rdf_sink)->openw; $on_triple = sub { $model->add_statement(statement(@_)) }; $on_done = sub { RDF::Trine::Serializer->new('RDFXML')->serialize_model_to_file($fh, $model) }; } my $pem = $tempdir->file('cert.pem')->slurp; my $cert = $class->new(pem => $pem); my $hex = sub { (my $h = shift->as_hex) =~ s/^0x//; $h; }; my $k = blank(); $on_triple->($k, u('rdf:type'), u('cert:RSAPublicKey')); $on_triple->($k, u('cert:modulus'), literal($cert->modulus->$hex, undef, uu('xsd:hexBinary'))); $on_triple->($k, u('cert:exponent'), literal($cert->exponent->bstr, undef, uu('xsd:integer'))); foreach my $san (@$sans) { next unless $san->type eq 'uniformResourceIdentifier'; $on_triple->(iri($san->value), u('cert:key'), $k); } $on_done->(); $tempdir->rmtree; return $cert; } __PACKAGE__ __END__ =head1 NAME Web::ID::Certificate::Generator - role for Web::ID::Certificate =head1 SYNOPSIS use Web::ID::Certificate::Generator; my %options = ( cert_output => '/home/alice/webid.p12', passphrase => 's3cr3t s0urc3', rdf_output => '/home/alice/public_html/foaf.rdf', subject_alt_names => [ Web::ID::SAN::URI->new( value => 'http://example.com/~alice/foaf.rdf#me', ), Web::ID::SAN::Email->new( value => 'alice@example.com', ), ], subject_name => 'Alice Jones', subject_locality => 'Lewes', subject_region => 'East Sussex', subject_country => 'GB', # ISO 3166-1 alpha-2 code ); my $cert = Web::ID::Certificate->generate(%options); =head1 DESCRIPTION This is a role that may be applied to L. It is not consumed by Web::ID::Certificate by default as I was trying to avoid tainting the class with the horror that's found in this role. The C routine of this package applies the role to Web::ID::Certificate, so it is sufficient to do: use Web::ID::Certificate::Generator; You don't need to muck around with C yourself. =head2 Constructor =over =item C<< generate(%options) >> Generates a brand new WebID-enabled certificate. =back =head2 Options The following options can be passed to C =over =item * C A passphrase-protected PKCS12 certificate file is generated as part of the certificate generation process. The PKCS12 file is what you'd typically import into a browser. You can pass a scalar reference, in which case the PKCS12 data will be written to that scalar; or a file handle or string file name. This is a required option. =item * C The password for the PKCS12 file. This is a required option. =item * C RDF data is also generated as part of the certificate generation process. Again a file handle or string file name can be passed, or an L. This is a required option. =item * C List of L objects to generate the certificate's subjectAltNames field. You want at least one L in there. This is a required option. =item * C The name of the person who will hold the certificate. (e.g. "Alice Smith".) This is a required option. =item * C The certificate holder's organisation. Not required. =item * C The locality (e.g. city) of the certificate holder's address. Not required. =item * C The region (e.g. state or county) of the certificate holder's address. Not required. =item * C Two letter ISO code for the country of the certificate holder's address. Not required. =item * C The path to the OpenSSL binary. Yes that's right, this role calls the OpenSSL binary via C calls. Defaults to "/usr/bin/openssl" (or "c:\openssl\bin\openssl.exe" on Windows). =item * C Key size in bits. Defaults to 1024. Bigger keys are more secure. Keys bigger than 2048 bits will take a ridiculously long time to generate. Keys less than 512 bits are pretty poor. =item * C Date when the certificate should expire, as a L object. Defaults to 365 days. =back =head1 BUGS AND LIMITATIONS Generating the private key results in shedloads of nasty crud being spewed out on STDERR. Please report any bugs to L. =head1 SEE ALSO L, L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID/Util.pm0000644000076400007640000001321612062674743013732 0ustar taitaipackage Web::ID::Util; use 5.010; use strict; use utf8; BEGIN { $Web::ID::Util::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::Util::VERSION = '1.922'; } use Carp qw/confess/; use Math::BigInt 0 try => 'GMP'; use RDF::Trine::NamespaceMap; use List::MoreUtils qw(:all !true !false); our (@EXPORT, @EXPORT_OK); BEGIN { @EXPORT = qw(make_bigint_from_node get_trine_model u uu true false read_only read_write); @EXPORT_OK = (@EXPORT, grep {!/^(true|false)$/} @List::MoreUtils::EXPORT_OK); } use Sub::Exporter -setup => { exports => \@EXPORT_OK, groups => { default => \@EXPORT, all => \@EXPORT_OK, }, }; use constant { read_only => 'ro', read_write => 'rw', }; use constant { true => !!1, false => !!0, }; sub u (;$) { state $namespaces //= RDF::Trine::NamespaceMap->new({ rdf => 'http://www.w3.org/1999/02/22-rdf-syntax-ns#', rdfs => 'http://www.w3.org/2000/01/rdf-schema#', owl => 'http://www.w3.org/2002/07/owl#', xsd => 'http://www.w3.org/2001/XMLSchema#', foaf => 'http://xmlns.com/foaf/0.1/', cert => 'http://www.w3.org/ns/auth/cert#', rsa => 'http://www.w3.org/ns/auth/rsa#', }); if (@_) { my $rv = $namespaces->uri(@_) or confess "couldn't expand term $_[0]"; return $rv; } return $namespaces; } sub uu ($) { return u(shift)->uri; } sub get_trine_model { my ($uri, $model) = @_; $model //= RDF::Trine::Model->new; eval { RDF::Trine::Parser->parse_url_into_model($uri, $model); }; return $model; } sub make_bigint_from_node { my ($node, %opts) = @_; state $test_hex = [ uu('cert:hex'), uu('xsd:hexBinary'), ]; state $test_unsigned = [ uu('cert:decimal'), uu('cert:int'), uu('xsd:unsignedLong'), uu('xsd:unsignedInt'), uu('xsd:unsignedShort'), uu('xsd:unsignedByte'), uu('xsd:positiveInteger'), uu('xsd:nonNegitiveInteger'), ]; state $test_signed = [ uu('xsd:integer'), uu('xsd:negitiveInteger'), uu('xsd:nonPositiveInteger'), uu('xsd:long'), uu('xsd:short'), uu('xsd:int'), uu('xsd:byte'), ]; state $test_decimal = uu('xsd:decimal'); if ($node->is_literal) { given ($node->literal_datatype) { when ($_ ~~ $test_hex) { ( my $hex = $node->literal_value ) =~ s/[^0-9A-F]//ig; return Math::BigInt->from_hex("0x$hex"); } when ($_ ~~ $test_unsigned) { ( my $dec = $node->literal_value ) =~ s/[^0-9]//ig; return Math::BigInt->new("$dec"); } when ($_ ~~ $test_signed) { ( my $dec = $node->literal_value ) =~ s/[^0-9-]//ig; return Math::BigInt->new("$dec"); } when ($_ ~~ $test_decimal) { my ($dec, $frac) = split /\./, $node->literal_value, 2; warn "Ignoring fractional part of xsd:decimal number." if defined $frac; $dec =~ s/[^0-9-]//ig; return Math::BigInt->new("$dec"); } when ($_ ~~ undef) { $opts{'fallback'} = $node; } } } if (defined( my $node = $opts{'fallback'} ) and $opts{'fallback'}->is_literal) { if ($opts{'fallback_type'} eq 'hex') { (my $hex = $node->literal_value) =~ s/[^0-9A-F]//ig; return Math::BigInt->from_hex("0x$hex"); } else # dec { my ($dec, $frac) = split /\./, $node->literal_value, 2; warn "Ignoring fractional part of xsd:decimal number." if defined $frac; $dec =~ s/[^0-9]//ig; return Math::BigInt->new("$dec"); } } return; } __PACKAGE__ __END__ =head1 NAME Web::ID::Util - utility functions used in Web-ID =head1 DESCRIPTION These are utility functions which I found useful building Web-ID. Many of them may also be useful creating the kind of apps that Web-ID is used to authenticate for. Here is a very brief summary. By default, they're B exported to your namespace. (This modulue uses L so you get pretty good control over what gets exported.) =over =item C - constant for true =item C - constant for false =item C - constant for string 'ro' (nice for Moose/Mouse) =item C - constant for string 'rw' (nice for Moose/Mouse) =item C<< get_trine_model($url) >> - fetches a URL and parses RDF into an L =item C<< u($curie) >> - expands a CURIE, returning an L =item C<< uu($curie) >> - as per C<< u($curie) >>, but returns string =item C<< u() >> - called with no CURIE, returns the L used to map CURIEs to URIs =item C<< make_bigint_from_node($node, %options) >> - makes a L object from a numeric L. Supports most datatypes you'd care about, including hexadecimally ones. Supported options are C which provides a fallback node which will be used when C<< $node >> is non-literal; and C either 'dec' or 'hex' which is used when parsing the fallback node, or if C<< $node >> is a plain literal. (The actual datatype of the fallback node is ignored for hysterical raisins.) =back Additionally, any function from L can be exported by request, except C and C as they conflict with the constants above. use Web::ID::Utils qw(:default uniq); =head1 BUGS I don't wanna hear about them unless they cause knock-on bugs for L itself. =head1 SEE ALSO L, L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID/SAN/0000755000076400007640000000000012063103671013061 5ustar taitaiWeb-ID-1.922/lib/Web/ID/SAN/Email.pm0000644000076400007640000000665712062674743014500 0ustar taitaipackage Web::ID::SAN::Email; use 5.010; use utf8; our $WWW_Finger = 0; BEGIN { $Web::ID::SAN::Email::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::SAN::Email::VERSION = '1.922'; eval { no warnings; require WWW::Finger; WWW::Finger->VERSION('0.100'); $WWW_Finger++; } } use MooseX::Types::Moose -all; use Web::ID::Types -all; use Web::ID::Util; use Moose; use namespace::sweep; extends 'Web::ID::SAN'; has '+type' => (default => 'rfc822Name'); has finger => ( is => read_only, isa => Finger | Undef, lazy => true, builder => '_build_finger', ); sub _build_finger { my ($self) = @_; return WWW::Finger->new($self->value); } around _build_model => sub { my ($orig, $self) = @_; if (my $finger = $self->finger) { if ($finger->endpoint) { my $store = RDF::Trine::Store::SPARQL->new($finger->endpoint); return RDF::Trine::Model->new($store); } return $finger->graph; } $self->$orig(); }; around associated_keys => sub { my ($orig, $self) = @_; my @keys = $self->$orig; my $results = $self->_query->execute( $self->model ); RESULT: while (my $result = $results->next) { my $modulus = make_bigint_from_node( $result->{modulus}, fallback => $result->{hexModulus}, fallback_type =>'hex', ); my $exponent = make_bigint_from_node( $result->{exponent}, fallback => $result->{decExponent}, fallback_type =>'dec', ); my $key = $self->key_factory->( modulus => $modulus, exponent => $exponent, ); push @keys, $key if $key; } return @keys; }; sub _query { my ($self) = @_; my $email = 'mailto:' . $self->value; return "RDF::Query"->new( sprintf(<<'SPARQL', (($email)x4)) ); PREFIX cert: PREFIX rsa: PREFIX foaf: SELECT ?webid ?modulus ?exponent ?decExponent ?hexModulus WHERE { { ?webid foaf:mbox <%s> . ?key cert:identity ?webid ; rsa:modulus ?modulus ; rsa:public_exponent ?exponent . } UNION { ?webid foaf:mbox <%s> ; cert:key ?key . ?key rsa:modulus ?modulus ; rsa:public_exponent ?exponent . } UNION { ?webid foaf:mbox <%s> . ?key cert:identity ?webid ; cert:modulus ?modulus ; cert:exponent ?exponent . } UNION { ?webid foaf:mbox <%s> ; cert:key ?key . ?key cert:modulus ?modulus ; cert:exponent ?exponent . } OPTIONAL { ?modulus cert:hex ?hexModulus . } OPTIONAL { ?exponent cert:decimal ?decExponent . } } SPARQL } __PACKAGE__ __END__ =head1 NAME Web::ID::SAN::Email - represents subjectAltNames that are e-mail addresses =head1 DESCRIPTION This module uses L (if installed) to attempt to locate some RDF data about the holder of the given e-mail address. It is probably not especially interoperable with other WebID implementations. =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L, L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID/SAN/URI.pm0000644000076400007640000000556512062674743014105 0ustar taitaipackage Web::ID::SAN::URI; use 5.010; use utf8; BEGIN { $Web::ID::SAN::URI::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::SAN::URI::VERSION = '1.922'; } use MooseX::Types::Moose -all; use Web::ID::Types -all; use Web::ID::Util; use Moose; use namespace::sweep; extends 'Web::ID::SAN'; has '+type' => (default => 'uniformResourceIdentifier'); override uri_object => sub { my ($self) = @_; return URI->new($self->value); }; around _build_model => sub { my ($orig, $self) = @_; my $model = $self->$orig; return get_trine_model($self->value => $model); }; around associated_keys => sub { my ($orig, $self) = @_; my @keys = $self->$orig; my $results = $self->_query->execute( $self->model ); RESULT: while (my $result = $results->next) { # trim any whitespace around modulus # (HACK for MyProfile WebIDs) # Should probably be in ::Util. $result->{modulus}->[0] =~ s/(^\s+)|(\s+$)//g; my $modulus = make_bigint_from_node( $result->{modulus}, fallback => $result->{hexModulus}, fallback_type =>'hex', ); my $exponent = make_bigint_from_node( $result->{exponent}, fallback => $result->{decExponent}, fallback_type =>'dec', ); my $key = $self->key_factory->( modulus => $modulus, exponent => $exponent, ); push @keys, $key if $key; } return @keys; }; sub _query { my ($self) = @_; return "RDF::Query"->new( sprintf(<<'SPARQL', (($self->uri_object)x4)) ); PREFIX cert: PREFIX rsa: SELECT ?modulus ?exponent ?decExponent ?hexModulus WHERE { { ?key cert:identity <%s> ; rsa:modulus ?modulus ; rsa:public_exponent ?exponent . } UNION { <%s> cert:key ?key . ?key rsa:modulus ?modulus ; rsa:public_exponent ?exponent . } UNION { ?key cert:identity <%s> ; cert:modulus ?modulus ; cert:exponent ?exponent . } UNION { <%s> cert:key ?key . ?key cert:modulus ?modulus ; cert:exponent ?exponent . } OPTIONAL { ?modulus cert:hex ?hexModulus . } OPTIONAL { ?exponent cert:decimal ?decExponent . } } SPARQL } __PACKAGE__ __END__ =head1 NAME Web::ID::SAN::URI - represents subjectAltNames that are URIs =head1 DESCRIPTION subjectAltNames such as these are the foundation of the whole WebID idea. =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L, L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID/Certificate.pm0000644000076400007640000001354512062674743015244 0ustar taitaipackage Web::ID::Certificate; use 5.010; use utf8; BEGIN { $Web::ID::Certificate::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::Certificate::VERSION = '1.922'; } use Crypt::X509 0.50 (); # why the hell does this export anything?! use DateTime 0; use MooseX::Types::Moose -all; use Digest::SHA qw(sha1_hex); use MIME::Base64 0 qw(decode_base64); use Web::ID::Types -all; use Web::ID::SAN; use Web::ID::SAN::Email; use Web::ID::SAN::URI; use Web::ID::Util qw(:default part); # Partly sorts a list of Web::ID::SAN objects, # prioritising URIs and Email addresses. # sub _sort_san { map { ref($_) eq 'ARRAY' ? (@$_) : () } part { if ($_->isa('Web::ID::SAN::URI')) { 0 } elsif ($_->isa('Web::ID::SAN::Email')) { 1 } else { 2 } } @_; } use Moose; use namespace::sweep -also => '_sort_san'; has pem => ( is => read_only, isa => Str, required => true, coerce => false, ); has _der => ( is => read_only, isa => Str, required => true, lazy_build => true, ); has _x509 => ( is => read_only, isa => 'Crypt::X509', lazy_build => true, ); has public_key => ( is => read_only, isa => Rsakey, lazy_build => true, handles => [qw(modulus exponent)], ); has subject_alt_names => ( is => read_only, isa => ArrayRef, lazy_build => true, ); has $_ => ( is => read_only, isa => Datetime, lazy_build => true, coerce => true, ) for qw( not_before not_after ); has san_factory => ( is => read_only, isa => CodeRef, lazy_build => true, ); has fingerprint => ( is => read_only, isa => Str, lazy_build => true, ); sub _build_fingerprint { lc sha1_hex( shift->_der ); } sub _build__der { my @lines = split /\n/, shift->pem; decode_base64(join "\n", grep { !/--(BEGIN|END) CERTIFICATE--/ } @lines); } sub _build__x509 { return Crypt::X509->new(cert => shift->_der); } sub _build_public_key { my ($self) = @_; Web::ID::RSAKey->new($self->_x509->pubkey_components); } sub _build_subject_alt_names { my ($self) = @_; my $factory = $self->san_factory; [_sort_san( map { my ($type, $value) = split /=/, $_, 2; $factory->(type => $type, value => $value); } @{ $self->_x509->SubjectAltName } )]; } sub _build_not_before { my ($self) = @_; return $self->_x509->not_before; } sub _build_not_after { my ($self) = @_; return $self->_x509->not_after; } my $default_san_factory = sub { my (%args) = @_; my $class = { uniformResourceIdentifier => 'Web::ID::SAN::URI', rfc822Name => 'Web::ID::SAN::Email', }->{ $args{type} } // 'Web::ID::SAN'; $class->new(%args); }; sub _build_san_factory { return $default_san_factory; } sub timely { my ($self, $now) = @_; $now //= DateTime->now; return if $now > $self->not_after; return if $now < $self->not_before; return $self; } __PACKAGE__ __END__ =head1 NAME Web::ID::Certificate - an x509 certificate =head1 SYNOPSIS my $cert = Web::ID::Certificate->new(pem => $pem_encoded_x509); foreach (@{ $cert->subject_alt_names }) { say "SAN: ", $_->type, " = ", $_->value; } =head1 DESCRIPTION =head2 Constructor =over =item C<< new >> Standard Moose-style constructor. =back =head2 Attributes =over =item C<< pem >> A PEM-encoded string for the certificate. This is usually the only attribute you want to pass to the constructor. Allow the others to be built automatically. =item C<< public_key >> A L object. =item C<< fingerprint >> A string identifier for the certificate. It is the lower-cased hexadecimal SHA1 hash of the DER-encoded certificate. This is not used in WebID authentication, but may be used as an identifier for the certificate if you need to keep it in a cache. =item C<< not_before >> L object indicating when the certificate started (or will start) to be valid. =item C<< not_after >> L object indicating when the certificate will cease (or has ceased) to be valid. =item C<< subject_alt_names >> An arrayref containing a list of subject alt names (L objects) associated with the certificate. These are sorted in the order they'll be tried for WebID authentication. =item C<< san_factory >> A coderef used for building L objects. It's very unlikely you need to play with this - the default is probably OK. But changing this is "supported" (in so much as any of this is supported). The coderef is passed a hash (not hashref) along the lines of: ( type => 'uniformResourceIdentifier', value => 'http://example.com/id/alice', ) =back =head2 Methods =over =item C<< timely >> Checks C and C against the current system time to indicate whether the certifixate is temporally valid. Returns a boolean. You can optionally pass it a L object to use instead of the current system time. =item C<< exponent >> Delegated to the C attribute. =item C<< modulus >> Delegated to the C attribute. =back =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L, L, L. L - augments this class to add the ability to generate new WebID certificates. L provides a pure Perl X.509 certificate parser, and is used internally by this module. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID/SAN.pm0000644000076400007640000000570412062674743013441 0ustar taitaipackage Web::ID::SAN; use 5.010; use utf8; BEGIN { $Web::ID::SAN::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::SAN::VERSION = '1.922'; } use MooseX::Types::Moose -all; use Web::ID::Types -all; use RDF::Query 2.900; use URI 0; use URI::Escape 0 qw/uri_escape/; use Web::ID::RSAKey; use Web::ID::Util; use Moose; use namespace::sweep; has $_ => ( is => read_only, isa => Str, required => true, coerce => false, ) for qw(type value); has model => ( is => read_only, isa => Model, lazy_build => true, ); has key_factory => ( is => read_only, isa => CodeRef, lazy_build => true, ); sub _build_model { return RDF::Trine::Model->new; } my $default_key_factory = sub { my (%args) = @_; return unless $args{exponent}; return unless $args{modulus}; Web::ID::RSAKey->new(%args); }; sub _build_key_factory { return $default_key_factory; } sub uri_object { my ($self) = @_; return URI->new(sprintf 'urn:x-subject-alt-name:%s:%s', map {uri_escape $_} $self->type, $self->value); } sub to_string { my ($self) = @_; sprintf('%s=%s', $self->type, $self->value); } sub associated_keys { return; } __PACKAGE__ __END__ =head1 NAME Web::ID::SAN - represents a single name from a certificate's subjectAltName field =head1 DESCRIPTION =head2 Constructor =over =item C<< new >> Standard Moose-style constructor. =back =head2 Attributes =over =item C<< type >> Something like 'uniformResourceIdentifier' or 'rfc822Name'. A string. =item C<< value >> The name itself. A string. =item C<< model >> An RDF::Trine::Model representing data about the subject identified by this name. To be useful, the C needs to be buildable automatically given C and C. =item C<< key_factory >> This is similar to the C found in L. It's a coderef used to construct L objects. =back =head2 Methods =over =item C<< uri_object >> Forces the name to take the form of a URI identifying the subject. It's not always an especially interesting URI. =item C<< to_string >> A printable form of the name. Not always very pretty. =item C<< associated_keys >> Finds RSA keys associated with this name in C, and returns them as a list of L objects. =back =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L, L, L, L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID/FAQ.pod0000644000076400007640000001411312062674743013567 0ustar taitai=head1 NAME Web::ID::FAQ - frequently asked questions about WebID =head1 FREQUENTLY ASKED QUESTIONS =head2 So what is WebID? Web Identification and Discovery. Firstly it's the concept of identifying people with HTTP URIs. URI stands for Uniform Resource Identifier. While often used as identifiers for web pages and other digital resources, they're just string identifiers and may be used to identify anything - car parts, gorillas, abstract concepts, and, yes, people. WebID is also a protocol that allows websites to discover which URI identifies you, using a secure certificate that is installed in your browser. =head2 URIs can identify non-digital resources? Yes. Of course, if you type a URI which identifies a web page into a web browser, you'd expect to see that web page (or an error message explaining why you cannot), but if you type a URI which identifies a car part, don't expect that spark plug to jump out of your screen into your hands. URIs that identify non-digital resouces should either be unresolvable (e.g. C<< urn:isbn:978-0099800200 >> which identifies a book - your browser can't do anything with that URI); should produce an error message explaining why the resource cannot be provided; or should redirect to a digital resource (e.g. C<< http://example.com/id/alice >> might identify Alice, and redirect to C<< http://example.com/data/alice >> which is a document with information about Alice). Further reading: I, L. =head2 So I can use WebID to limit who has access to my site? On its own, no. WebID allows a website to establish an identifier for a visitor, but what the website does with that information (whether it uses it to block access to certain resources) is beyond the scope of WebID. =head2 How does WebID work? In summary, your browser establishes an HTTPS connection to a web server. As part of the SSL/TLS handshake, the server can request that the browser identifies itself with a certificate. Your browser then sends your certificate to the server. This certificate includes a URI that identifies you. Behind the scenes, the server fetches that URI, and retrieves a profile document about you (this document can include as much or as little personal data about you as you like). This document uses the RDF data model, and contains data that allows the server to verify that the certificate exchanged as part of your HTTPS request really belongs to you. The user experience is that a WebID user visits a WebID-enabled site; their browser prompts them to pick a certificate from the list of installed certificates; they choose; the site knows who they are. No passwords are required (though many browsers do offer the option to protect the installed certificates with a password). =head2 So WebID requires HTTPS? WebID could theoretically be used over other SSL/TLS protocols, such as OpenVPN, secure IMAP/POP3 connections, and so forth. But yes, it only works over secure connections. Really, would you want to be identifying yourself over an insecure channel? =head2 How can I use WebID in Perl? For Plack/PSGI-based websites, there exists a module L to make things (relatively) easy. It stuffs the client's WebID URI into C<< $env->{WEBID} >>. For Catalyst-based websites, be aware that recent versions of Catalyst are built on Plack. See L for details. Otherwise, you need to use L directly. Assuming you've configured your web server to request a client certificate from the browser, and you've managed to get that client certificate into Perl in PEM format, then it's just: my $webid = Web::ID->new(certificate => $pem); my $uri = $webid->uri; And you have the URI. What is PEM? Well, X509 certificates come in a variety of different interrelated formats. PEM is a common one, and often what web servers make available. If you have DER though, it's easy to convert it to PEM: my $pem = "\n-----BEGIN CERTIFICATE-----\n" . encode_base64($der) . "\n-----END CERTIFICATE-----\n"; If you have another format, then OpenSSL may be able to convert it. Once you have the URI, you can use it as a plain old string identifier for the user, whenever you need to identify them in databases, etc. The C<< $webid >> object in the above example, or in the Plack middleware, C<< $env->{WEBID_OBJECT} >>, is an object blessed into the L package and will allow you to retrieve further information about the user - their name, e-mail address, blog URL, interests, friends, etc - depending on what information they've chosen to include in their profile. =head2 How does WebID compare to OpenID? Both use URIs to identify people, however the way they choose their URIs differs. In OpenID you use the same URI string to identify your blog or homepage, and to identify yourself. In WebID you use different URIs to identify different things - one URI for your blog, one for you. In WebID you almost never have to type that URI - it's embedded into a certificate in your browser's certificate store. WebID doesn't require typing or passwords. This makes it more suitable than OpenID for non-interactive processes (e.g. authenticated downloads run via a cron job). WebID requires a secure connection. WebID is built upon the architecture of the Semantic Web. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. This FAQ document is additionally available under the Creative Commons Attribution-ShareAlike 2.0 UK: England and Wales licence L, and the GNU Free Documentation License version 1.3, or at your option any later version L. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID/Types.pm0000644000076400007640000000420712062675053014114 0ustar taitaipackage Web::ID::Types; use 5.010; use strict; use utf8; BEGIN { $Web::ID::Types::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::Types::VERSION = '1.922'; } use DateTime; use Math::BigInt; use RDF::Trine; use URI; use MooseX::Types -declare => [qw[ Bigint Certificate Datetime Finger Model Rsakey San Uri ]]; use MooseX::Types::Moose -all; class_type Bigint, { class => 'Math::BigInt' }; coerce Bigint, from Str, via { "Math::BigInt"->new($_) }; class_type Certificate, { class => 'Web::ID::Certificate' }; coerce Certificate, from HashRef, via { "Web::ID::Certificate"->new(%$_) }, from Str, via { "Web::ID::Certificate"->new(pem => $_) }; class_type Datetime, { class => 'DateTime' }; coerce Datetime, from Num, via { "DateTime"->from_epoch(epoch => $_) }; class_type Finger, { class => 'WWW::Finger' }; coerce Finger, from Str, via { "WWW::Finger"->new($_) if UNIVERSAL::can('WWW::Finger', 'new') }; class_type Model, { class => 'RDF::Trine::Model' }; class_type Rsakey, { class => 'Web::ID::RSAKey' }; coerce Rsakey, from HashRef, via { "Web::ID::RSAKey"->new(%$_) }; class_type San, { class => 'Web::ID::SAN' }; class_type Uri, { class => 'URI' }; coerce Uri, from Str, via { "URI"->new($_) }; __PACKAGE__ __END__ =head1 NAME Web::ID::Types - type library for Web::ID and friends =head1 DESCRIPTION A L type library defining: =head2 Types =over =item * C =item * C =item * C =item * C =item * C =item * C =item * C =item * C =back =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID/RSAKey.pm0000644000076400007640000000326712062674744014121 0ustar taitaipackage Web::ID::RSAKey; use 5.010; use utf8; BEGIN { $Web::ID::RSAKey::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::RSAKey::VERSION = '1.922'; } use MooseX::Types::Moose -all; use Web::ID::Types -all; use Web::ID::Util; use Moose; use namespace::sweep; for (qw( exponent modulus )) { has $_ => ( is => read_only, isa => Bigint, required => true, coerce => true, ); } sub rsa_equal { my ($self, $other) = @_; foreach (qw(exponent modulus)) { my $m1 = $self->can($_) or return; my $m2 = $other->can($_) or return; return unless $self->$m1 == $other->$m2; } return true; } __PACKAGE__ __END__ =head1 NAME Web::ID::RSAKey - an RSA key =head1 DESCRIPTION =head2 Constructor =over =item C<< new >> Standard Moose-style constructor. =back =head2 Attributes =over =item C<< exponent >> The exponent as a Math::BigInt object. =item C<< modulus >> The modulus as a Math::BigInt object. =back =head2 Methods =over =item C<< rsa_equal($that) >> Returns true iff this key is the same as that key. =back =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L, L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Web/ID.pm0000644000076400007640000001361112062674744013015 0ustar taitaipackage Web::ID; use 5.010; use utf8; BEGIN { $Web::ID::AUTHORITY = 'cpan:TOBYINK'; $Web::ID::VERSION = '1.922'; } use MooseX::Types::Moose -all; use Web::ID::Types -all; use Web::ID::Certificate; use Web::ID::Util qw(:default uniq); use Moose; use namespace::sweep; has certificate => ( is => read_only, isa => Certificate, required => true, coerce => true, ); has uri => ( is => read_only, isa => Uri, lazy_build => true, coerce => true, ); has profile => ( is => read_only, isa => Model, lazy_build => true, ); has valid => ( is => read_only, isa => Bool, lazy_build => true, ); has first_valid_san => ( is => read_only, isa => San | Undef, lazy_build => true, ); sub _build_valid { my ($self) = @_; return false unless $self->certificate->timely; return true if defined $self->first_valid_san; return false; } sub _build_uri { my ($self) = @_; $self->first_valid_san->uri_object; } sub _build_profile { my ($self) = @_; $self->first_valid_san->model; } sub _build_first_valid_san { my ($self) = @_; my $cert = $self->certificate; my @sans = @{ $cert->subject_alt_names }; foreach my $san (@sans) { foreach my $key ( $san->associated_keys ) { return $san if $key->rsa_equal($cert); } } return undef; } sub node { my ($self) = @_; RDF::Trine::Node::Resource->new($self->uri.''); } sub get { my $self = shift; my @pred = map { if (blessed $_ and $_->isa('RDF::Trine::Node')) { $_ } else { u $_ } } @_; my @results = uniq map { $_->is_resource ? $_->uri : $_->literal_value } grep { $_->is_literal or $_->is_resource } $self->profile->objects_for_predicate_list($self->node, @pred); wantarray ? @results : $results[0]; } __PACKAGE__ __END__ =head1 NAME Web::ID - implementation of WebID (a.k.a. FOAF+SSL) =head1 SYNOPSIS my $webid = Web::ID->new(certificate => $pem_encoded_x509); if ($webid->valid) { say "Authenticated as: ", $webid->uri; } =head1 DESCRIPTION WebID is a simple authentication protocol based on TLS (Transaction Layer Security, better known as Secure Socket Layer, SSL) and the Semantic Web. This module provides a Perl implementation for authenticating clients using WebID. For more information see the L document. Bundled with this module are L, a plugin for L to perform WebID authentication on HTTPS connections; and L, a module that allows you to generate WebID-enabled certificates that can be installed into web browsers. =head2 Constructor =over =item C<< new >> Standard Moose-style constructor. =back =head2 Attributes =over =item C<< certificate >> A L object representing and x509 certificate, though a PEM-encoded string will be coerced. This is usually the only attribute you want to pass to the constructor. Allow the others to be built automatically. =item C<< first_valid_san >> Probably fairly uninteresting. This is the first subjectAltName value found in the certificate that could be successfully authenticated using Web::ID. An L object. =item C<< uri >> The URI associated with the first valid SAN. A L object. This is a URI you can use to identify the person, organisation or robotic poodle holding the certificate. =item C<< profile >> Data about the certificate holder. An L object. Their FOAF file (probably). =item C<< valid >> Boolean. =back =head2 Methods =over =item C<< node >> Returns the same as C, but as an L object. =item C<< get(@predicates) >> Queries the C for triples of the form: $self->node $predicate $x . And returns literal and URI values for $x, as strings. C<< $predicate >> should be an L, or a string. If a string, it will be expanded using L, so you can do stuff like: my $name = $webid->get('foaf:name', 'rdfs:label'); my @mboxes = $webid->get('foaf:mbox'); =back =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. L, L. L provides an access control system that complements WebID. L is the spiritual ancestor of this module though they share very little code, and have quite different APIs. General WebID information: L, L, L, L. Mailing list for general Perl RDF/SemWeb discussion and support: L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 THANKS Thanks to Kjetil Kjernsmo (cpan:KJETILK) for persuading me to port my old CGI-specific implementaton of this to Plack. Thanks Kjetil Kjernsmo (again), Florian Ragwitz (cpan:FLORA), and Jonas Smedegaard for help with testing and advice on dependencies. Thanks to Henry Story, Melvin Carvalho, Simon Reinhardt, Bruno Harbulot, Ian Jacobi and many others for developing WebID from a poorly thought out idea to a clever, yet simple and practical authentication protocol. Thanks to Gregory Williams (cpan:GWILLIAMS), Tatsuhiko Miyagawa (cpan:MIYAGAWA) and the Moose Cabal for providing really good platforms (RDF::Trine, Plack and Moose respectively) to build this on. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/lib/Plack/0000755000076400007640000000000012063103671012461 5ustar taitaiWeb-ID-1.922/lib/Plack/Middleware/0000755000076400007640000000000012063103671014536 5ustar taitaiWeb-ID-1.922/lib/Plack/Middleware/Auth/0000755000076400007640000000000012063103671015437 5ustar taitaiWeb-ID-1.922/lib/Plack/Middleware/Auth/WebID.pm0000644000076400007640000001624212062674744016751 0ustar taitaipackage Plack::Middleware::Auth::WebID; { $Plack::Middleware::Auth::WebID::AUTHORITY = 'cpan:TOBYINK'; $Plack::Middleware::Auth::WebID::VERSION = '1.922'; } use strict; use base qw(Plack::Middleware); use Plack::Util;; use Plack::Util::Accessor qw( webid_class certificate_env_key on_unauth no_object_please cache ); my $default_unauth = sub { my ($self, $env) = @_; $env->{WEBID} = Plack::Util::FALSE; $env->{WEBID_OBJECT} = Plack::Util::FALSE; $self->app->($env); }; sub prepare_app { my ($self) = @_; $self->certificate_env_key('SSL_CLIENT_CERT') unless defined $self->certificate_env_key; $self->webid_class('Web::ID') unless defined $self->webid_class; $self->on_unauth($default_unauth) unless defined $self->on_unauth; Plack::Util::load_class('Web::ID'); } sub call { my ($self, $env) = @_; my $unauth = $self->on_unauth; my $cert = $env->{ $self->certificate_env_key } or return $self->$unauth($env); my ($webid, $was_cached) = $self->_get_webid($cert, $env); if ($webid->valid) { $env->{WEBID} = $webid->uri . ''; $env->{WEBID_OBJECT} = $webid unless $self->no_object_please; $env->{WEBID_CACHE_HIT} = $was_cached; return $self->_run_app($env); } return $self->$unauth($env); } sub _run_app { my ($self, $env) = @_; my $app = $self->app; @_ = $env; goto $app; } sub _get_webid { my ($self, $cert) = @_; my $webid = $self->webid_class->new(certificate => $cert); return ($webid, '') unless $self->cache; # I know what you're thinking... what's the point in caching these # objects, if we're already constructed it above?! # # Well, much of the heavy work for Web::ID is done in lazy builders. # If we return a cached copy of the object, then we avoid running # those builders again. # my $cached = $self->cache->get( $webid->certificate->fingerprint ); return ($cached, '1') if $cached; $self->cache->set($webid->certificate->fingerprint, $webid); return ($webid, '0'); } __PACKAGE__ __END__ =head1 NAME Plack::Middleware::Auth::WebID - authentication middleware for WebID =head1 SYNOPSIS use Plack::Builder; my $app = sub { ... }; my $cache = CHI->new( ... ); sub unauthenticated { my ($self, $env) = @_; return [ 403, [ 'Content-Type' => 'text/plain' ], [ '403 Forbidden' ], ]; } builder { enable "Auth::WebID", cache => $cache, on_unauth => \&unauthenticated; $app; }; =head1 DESCRIPTION Plack::Middleware::Auth::WebID is a WebID handler for Plack. If authentication is successful, then the handler sets C<< $env->{WEBID} >> to the user's WebID URI, and sets C<< $env->{WEBID_OBJECT} >> to a L object. =begin private =item call =item prepare_app =end private =head1 CONFIGURATION =over 4 =item cache This may be set to an object that will act as a cache for Web::ID objects. Plack::Middleware::Auth::WebID does not care what package you use for your caching needs. L, L and L should all work. In fact, any package that provides a similar one-argument C and a two-argument C ought to work. Which should you use? Well CHI seems to be best, however it's Moose-based, so usually too slow for CGI applications. Use Cache::Cache for CGI, and CHI otherwise. You don't need to set a cache at all, but if there's no cache, then reauthentication (which is computationally expensive) happens for every request. Use of a cache with an expiration time of around 15 minutes should significantly speed up the responsiveness of a WebID-secured site. (For forking servers you probably want a cache that is shared between processes, such as a memcached cache.) =item on_unauth Coderef that will be called if authentication is not successful. You can use this to return a "403 Forbidden" page for example, or try an alternative authentication method. The default coderef used will simply run the application as normal, but setting C<< $env->{WEBID} >> to the empty string. =item webid_class Name of an alternative class to use for WebID authentication instead of L. Note that any such class would need to provide a compatible C constructor. =item certificate_env_key The key within C<< $env >> where Plack::Middleware::Auth::WebID can find a PEM-encoded client SSL certificate. Apache keeps this information in C<< $env->{'SSL_CLIENT_CERT'} >>, so it should be no surprise that this setting defaults to 'SSL_CLIENT_CERT'. =item no_object_please Suppresses setting C<< $env->{WEBID_OBJECT} >>. C<< $env->{WEBID} >> will still be set as usual. =back =head1 SERVER SUPPORT WebID is an authentication system based on the Semantic Web and HTTPS. It relies on client certificates (but not on certification authorities; self-signed certificates are OK). So for this authentication module to work... =over =item * You need to be using a server which supports HTTPS. Many web PSGI web servers (e.g. HTTP::Server::Simple, Starman, etc) do not support HTTPS natively. In some cases these are used with an HTTPS proxy in front of them. =item * Your HTTPS server needs to request a client certificate from the client. =item * Your HTTPS server needs to expose the client certificate to Plack via C<< $env >>. If you're using an HTTPS proxy in front of a non-HTTPS web server, then you might need to be creative to find a way to forward this information to your backend web server. =item * The client browser needs to have a WebID-compatible certificate installed. Nuff said. =back =head2 Apache2 (mod_perl and CGI) The B directive can be used to tell Apache that you want it to request a certificate from the client. Apache is able to deposit the certifcate in an environment variable called SSL_CLIENT_CERT. However by default it might not. Check out the B directive and enable the C option, or if you're using mod_perl try L. =head2 Gepok L is one of a very small number of PSGI-compatible web servers that supports HTTPS natively. As of 0.20 it will request client certificates, but you will need to use L in order to make the certificate available in the PSGI C<< $env >> hashref. =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L, L, L. General WebID information: L, L, L, L. Apache mod_ssl: L, L, L. Gepok: L, L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2012 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. Web-ID-1.922/MANIFEST0000644000076400007640000000227312063103671012016 0ustar taitaiChanges COPYRIGHT examples/certificate-generation.pl examples/certificate-parsing.pl examples/fingerpoint-test.pl examples/web-id-validation.pl inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/AutoManifest.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Package.pm inc/Module/Install/TrustMetaYml.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Module/Package.pm inc/Module/Package/Dist/RDF.pm inc/Scalar/Util.pm inc/unicore/Name.pm inc/utf8.pm inc/YAML/Tiny.pm lib/Plack/Middleware/Auth/WebID.pm lib/Web/ID.pm lib/Web/ID/Certificate.pm lib/Web/ID/Certificate/Generator.pm lib/Web/ID/FAQ.pod lib/Web/ID/RSAKey.pm lib/Web/ID/SAN.pm lib/Web/ID/SAN/Email.pm lib/Web/ID/SAN/URI.pm lib/Web/ID/Types.pm lib/Web/ID/Util.pm LICENSE Makefile.PL MANIFEST This list of files META.yml meta/changes.ttl meta/doap.ttl meta/makefile.ttl README t/01mouse.t t/02moose.t t/03certificate.t t/04webid.t t/lib/Test/HTTP/Server.pm SIGNATURE Public-key signature (added by MakeMaker) Web-ID-1.922/SIGNATURE0000644000076400007640000001005312063103672012145 0ustar taitaiThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.68. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 568b8921ee3ce7af89e882ae852eebb3efe254d0 COPYRIGHT SHA1 864c904ac3be5fd1286f49eb0412a1f84e3de644 Changes SHA1 cc087c3dd6e1b519c680e68cd0231735a68300a0 LICENSE SHA1 30c56b702d2e1184ecaeb4d46c131ac71d18c9c3 MANIFEST SHA1 495da5a97df0d819d70b14b04637d1dfe2d13726 META.yml SHA1 7150e5e086ef493e1e527a1eeec44a8344b80db6 Makefile.PL SHA1 ed014dcabc60e78266b5e691cc56a853018be058 README SHA1 42fd4caeb9333e3f37e86c2bdb38cec4ccbc78c0 examples/certificate-generation.pl SHA1 03d3c6b48b15ad2bbbcfea677a3257374c208c0a examples/certificate-parsing.pl SHA1 25a49eb596594a24623220134cedcb4d7e6d477c examples/fingerpoint-test.pl SHA1 477d08c3e793ffbc4e2ed23d5a0dfbef135a304d examples/web-id-validation.pl SHA1 06c410f05488c1612ed66b06d3a86b2580581e4a inc/Module/AutoInstall.pm SHA1 8a924add836b60fb23b25c8506d45945e02f42f4 inc/Module/Install.pm SHA1 61ab1dd37e33ddbe155907ce51df8a3e56ac8bbf inc/Module/Install/AutoInstall.pm SHA1 c04f94f91fa97b9f8cfb5a36071098ab0e6c78e3 inc/Module/Install/AutoManifest.pm SHA1 2d0fad3bf255f8c1e7e1e34eafccc4f595603ddc inc/Module/Install/Base.pm SHA1 f0e01fff7d73cd145fbf22331579918d4628ddb0 inc/Module/Install/Can.pm SHA1 7328966e4fda0c8451a6d3850704da0b84ac1540 inc/Module/Install/Fetch.pm SHA1 66d3d335a03492583a3be121a7d888f63f08412c inc/Module/Install/Include.pm SHA1 b62ca5e2d58fa66766ccf4d64574f9e1a2250b34 inc/Module/Install/Makefile.pm SHA1 1aa925be410bb3bfcd84a16985921f66073cc1d2 inc/Module/Install/Metadata.pm SHA1 3b9281ddf7dd6d6f5de0a9642c69333023193c80 inc/Module/Install/Package.pm SHA1 9de7b5129351499c048328dfa718d0eab557cf30 inc/Module/Install/TrustMetaYml.pm SHA1 e4196994fa75e98bdfa2be0bdeeffef66de88171 inc/Module/Install/Win32.pm SHA1 c3a6d0d5b84feb3280622e9599e86247d58b0d18 inc/Module/Install/WriteAll.pm SHA1 26d58a041cd6b3d21db98b32e8fd1841aae21204 inc/Module/Package.pm SHA1 c18deb3025b83dda8ac7c97f1e29599e1d2c7378 inc/Module/Package/Dist/RDF.pm SHA1 0e0eed2e69d9583081868cf4f220068d0a018568 inc/Scalar/Util.pm SHA1 feb933cefe2e3762e8322bd6071a2499f3440da1 inc/YAML/Tiny.pm SHA1 8105c0510a773b56840995fb4dd2dc64fe9ddaee inc/unicore/Name.pm SHA1 36df501c7c9b73c282c5174ed54d8283b2f2cbf2 inc/utf8.pm SHA1 5b618cd1a6530533623885c724dbfdfcc7180eee lib/Plack/Middleware/Auth/WebID.pm SHA1 8f088e526e81218e1f5ee9f22a0dbce8db6540e2 lib/Web/ID.pm SHA1 b8a91f71ad902a64836efd88a42a9933320e946f lib/Web/ID/Certificate.pm SHA1 07fc4ca25ab343072d87874df990a3b173c0902f lib/Web/ID/Certificate/Generator.pm SHA1 f5814fea529758d9913f8211f44e852644f14bba lib/Web/ID/FAQ.pod SHA1 63c487afa55da7539c54801507707ef632a7459f lib/Web/ID/RSAKey.pm SHA1 de94829ea159dddf257e50cfa8a89f0d4ee69f21 lib/Web/ID/SAN.pm SHA1 7fee015ecffa764308ce88e801f6ba8daa8c5c6b lib/Web/ID/SAN/Email.pm SHA1 18d236695b0064c88f6ab7a5e29802421cf086fb lib/Web/ID/SAN/URI.pm SHA1 6f272a60725716f82b5d91cbda7f0b91d6a76436 lib/Web/ID/Types.pm SHA1 1803fd0fb5d1c1529ed491c1584bdcf2f184b3e3 lib/Web/ID/Util.pm SHA1 62e0a799ac94cfd47922516e50571f90ebf635a6 meta/changes.ttl SHA1 e9fd3cc2c94f030592333eda8c4737e6675c8ad2 meta/doap.ttl SHA1 aacdfcc0b2266906f99d8a6faffdc73afc032e0d meta/makefile.ttl SHA1 311478d30fce690179458dd8b5ca2afc951c8e42 t/01mouse.t SHA1 61357e85d9676b656a5cedf29618fbdcfc7405b3 t/02moose.t SHA1 6bccc6bac755209db20f7eb4ccfe2fbcb6780d06 t/03certificate.t SHA1 9c8d2eba7da5cf859fb9156ce83f8bf2b955cbcf t/04webid.t SHA1 c145c4023e4f8a015b0110476aedd8deccac81e2 t/lib/Test/HTTP/Server.pm -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.10 (GNU/Linux) iEYEARECAAYFAlDMh7oACgkQzr+BKGoqfTnm5wCgkbhhgyuuRxSz5BSWLBCdaFMj 28oAni2sojBpyTglH1rVdzHEhZZ4QP0R =mAIY -----END PGP SIGNATURE----- Web-ID-1.922/LICENSE0000644000076400007640000004374412063103600011672 0ustar taitaiThis software is copyright (c) 2012 by Toby Inkster . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2012 by Toby Inkster . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2012 by Toby Inkster . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Web-ID-1.922/examples/0000755000076400007640000000000012063103671012477 5ustar taitaiWeb-ID-1.922/examples/fingerpoint-test.pl0000644000076400007640000000044711750316625016351 0ustar taitaiuse 5.010; use Web::ID::SAN::Email; use RDF::Trine; my $san = Web::ID::SAN::Email->new( type => 'rfc822Address', value => 'somebody@fingerpoint.tobyinkster.co.uk', ); say $san->uri_object; print RDF::Trine::Serializer -> new('Turtle') -> serialize_model_to_string( $san->model ); Web-ID-1.922/examples/web-id-validation.pl0000644000076400007640000000320411750316625016341 0ustar taitaiuse 5.010; use lib "../lib"; use lib "lib"; use Data::Dumper; #use Moose (); use Web::ID; my $id = Web::ID->new( certificate => <first_valid_san->to_string; say "URI: ", $id->uri; say "Email: ", join ';', $id->get('foaf:mbox'); Web-ID-1.922/examples/certificate-parsing.pl0000644000076400007640000000350411750316625016770 0ustar taitaiuse 5.010; use lib "../lib"; use lib "lib"; use Data::Dumper; #use Moose (); use Web::ID::Certificate; use Web::ID::SAN; use Web::ID::SAN::Email; use Web::ID::SAN::URI; my $cert = Web::ID::Certificate->new( pem => <not_before, " -- ", $cert->not_after; say "Exponent: ", $cert->exponent; say "Modulus: ", $cert->modulus; say "Subject alt names: ", Dumper($cert->subject_alt_names); say "Fingerprint: ", $cert->fingerprint; Web-ID-1.922/examples/certificate-generation.pl0000644000076400007640000000075611752214012017453 0ustar taitaiuse Web::ID::Certificate::Generator; Web::ID::Certificate->generate( passphrase => 'test1234', subject_alt_names => [ Web::ID::SAN::URI->new(value => 'http://example.com/id/alice'), Web::ID::SAN::URI->new(value => 'http://example.net/id/alice'), ], cert_output => \(my $output), rdf_output => \(my $model), subject_cn => 'Alice Test', subject_country => 'gb', ); print RDF::Trine::Serializer -> new('RDFXML') -> serialize_model_to_string($model); Web-ID-1.922/Makefile.PL0000644000076400007640000000005211750316625012637 0ustar taitaiuse inc::Module::Package 'RDF:standard'; Web-ID-1.922/meta/0000755000076400007640000000000012063103671011607 5ustar taitaiWeb-ID-1.922/meta/makefile.ttl0000644000076400007640000000112112062673420014107 0ustar taitai# This file provides instructions for packaging. @prefix : . :perl_version_from _:main ; :version_from _:main ; :readme_from _:main ; :requires "Crypt::X509", "DateTime", "Digest::SHA", "List::MoreUtils", "Moose", "MooseX::Types", "namespace::sweep", "Path::Class", "Plack", "RDF::Query 2.900", "RDF::Trine 1.000", "Sub::Exporter", "URI"; :test_requires "Test::More 0.61" . _:main "lib/Web/ID.pm" . Web-ID-1.922/meta/doap.ttl0000644000076400007640000000243611752702360013270 0ustar taitai# This file contains general metadata about the project. @prefix : . @prefix dc: . @prefix foaf: . @prefix rdfs: . @prefix xsd: . a :Project ; :programming-language "Perl" ; :name "Web-ID" ; :shortdesc "implementation of WebID (a.k.a. FOAF+SSL)" ; :homepage ; :download-page ; :repository [ a :HgRepository; :browse ] ; :bug-database ; :created "2012-04-26"^^xsd:date ; :license ; rdfs:seeAlso ; :developer . dc:title "the same terms as the perl 5 programming language system itself" . a foaf:Person ; foaf:name "Toby Inkster" ; foaf:mbox . Web-ID-1.922/meta/changes.ttl0000644000076400007640000001124512062700675013755 0ustar taitai# This file acts as the project's changelog. @prefix : . @prefix dcs: . @prefix dc: . @prefix dist: . @prefix rdfs: . @prefix xsd: . @prefix cpanid: . @prefix foaf: . dist:project :release dist:v_1-910_01 . dist:v_1-910_01 a :Version ; dc:issued "2012-05-07"^^xsd:date ; :revision "1.910_01"^^xsd:string ; :file-release ; dcs:changeset [ dcs:versus ; dcs:item [ rdfs:label "Almost complete rewrite of CGI::Auth::FOAF_SSL. Very different (and much cleaner) API."@en ] ]. dist:project :release dist:v_1-910_02 . dist:v_1-910_02 a :Version ; dc:issued "2012-05-08"^^xsd:date ; :revision "1.910_02"^^xsd:string ; :file-release ; dcs:changeset [ dcs:versus dist:v_1-910_01 ; dcs:item [ rdfs:label "Improve Web::ID DESCRIPTION."@en ; a dcs:Documentation ; dcs:thanks ]; dcs:item [ rdfs:label "Add Any::Moose stuff to Web::ID BUGS section."@en ; a dcs:Documentation ; dcs:thanks cpanid:flora ]; dcs:item [ rdfs:label "Replace deprecated Digest::SHA1 with Digest::SHA."@en ; a dcs:Update ; dcs:thanks ] ]. a foaf:Person ; foaf:name "Jonas Smedegaard" . cpanid:flora a foaf:Person ; foaf:name "Florian Ragwitz" ; foaf:mbox . dist:project :release dist:v_1-910_03 . dist:v_1-910_03 a :Version ; dc:issued "2012-05-09"^^xsd:date ; :revision "1.910_03"^^xsd:string ; :file-release ; dcs:changeset [ dcs:versus dist:v_1-910_02 ; dcs:item [ rdfs:label "Better hooks for subclassing Plack::Middleware::Auth::WebID."@en ] ]. dist:project :release dist:v_1-910_04 . dist:v_1-910_04 a :Version ; dc:issued "2012-05-09"^^xsd:date ; :revision "1.910_04"^^xsd:string ; :file-release ; dcs:changeset [ dcs:versus dist:v_1-910_03 ; dcs:item [ rdfs:label "Drop dependency on Class::Load; use load_class from Plack::Util instead."@en ] ; dcs:item [ rdfs:label "Use File::Temp and Path::Class in t/04webid.t - they're already dependencies, so might as well."@en; dcs:thanks cpanid:kjetilk ] ]. cpanid:kjetilk a foaf:Person ; foaf:name "Kjetil Kjernsmo" ; foaf:mbox . dist:project :release dist:v_1-920 . dist:v_1-920 a :Version ; dc:issued "2012-05-10"^^xsd:date ; :revision "1.920"^^xsd:string ; :file-release ; dcs:changeset [ dcs:versus dist:v_1-910_04 ; dcs:item [ rdfs:label "Minor documentation changes."@en; a dcs:Documentation ] ; dcs:item [ rdfs:label "Mark as non-development release."@en; a dcs:Packaging ] ]. dist:project :release dist:v_1-921 . dist:v_1-921 a :Version ; dc:issued "2012-05-20"^^xsd:date ; :revision "1.921"^^xsd:string ; :file-release ; dcs:changeset [ dcs:versus dist:v_1-920 ; dcs:item [ rdfs:label "Add version number (0.06) to MouseX::Types dependency."@en; a dcs:Packaging ] ]. dist:project :release dist:v_1-922 . dist:v_1-922 a :Version ; dc:issued "2012-12-15"^^xsd:date ; :revision "1.922"^^xsd:string ; :file-release ; dcs:changeset [ dcs:versus dist:v_1-921 ; dcs:item [ rdfs:label "RDF::Trine now uses Moose, so there's no reason for Web::ID to continue using Any::Moose. All the old Any::Moose/Mouse stuff is now gone, and Web::ID now uses Moose and MooseX::Types."@en; a dcs:Update ]; dcs:item [ rdfs:label "Switched from namespace::clean to namespace::sweep."@en; a dcs:Update ]; dcs:item [ rdfs:label "Documented test suite."@en; a dcs:Documentation ]; dcs:item [ rdfs:label "Make test suite output cleaner (no openssl junk) if Capture::Tiny is available."@en; a dcs:Change ]; ]. Web-ID-1.922/META.yml0000644000076400007640000000174212063103605012133 0ustar taitai--- abstract: 'implementation of WebID (a.k.a. FOAF+SSL)' author: - 'Toby Inkster ' build_requires: ExtUtils::MakeMaker: 6.59 Test::More: 0.61 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 0 generated_by: 'Module::Install version 1.06' keywords: [] license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: Web::ID name: Web-ID no_index: directory: - examples - inc - t - xt requires: Crypt::X509: 0 DateTime: 0 Digest::SHA: 0 List::MoreUtils: 0 Moose: 0 MooseX::Types: 0 Path::Class: 0 Plack: 0 RDF::Query: 2.900 RDF::Trine: 1.000 Sub::Exporter: 0 URI: 0 namespace::sweep: 0 perl: 5.10.0 resources: bugtracker: http://rt.cpan.org/Dist/Display.html?Queue=Web-ID homepage: https://metacpan.org/release/Web-ID license: http://dev.perl.org/licenses/ repository: https://bitbucket.org/tobyink/p5-web-id version: 1.922 Web-ID-1.922/Changes0000644000076400007640000000270312063103577012163 0ustar taitaiWeb-ID ====== Created: 2012-04-26 Home page: Bug tracker: 1.922 2012-12-15 - (Documentation) Documented test suite. - (Update) RDF::Trine now uses Moose, so there's no reason for Web::ID to continue using Any::Moose. All the old Any::Moose/Mouse stuff is now gone, and Web::ID now uses Moose and MooseX::Types. - (Update) Switched from namespace::clean to namespace::sweep. - Make test suite output cleaner (no openssl junk) if Capture::Tiny is available. 1.921 2012-05-20 - (Packaging) Add version number (0.06) to MouseX::Types dependency. 1.920 2012-05-10 - (Documentation) Minor documentation changes. - (Packaging) Mark as non-development release. 1.910_04 2012-05-09 - Drop dependency on Class::Load; use load_class from Plack::Util instead. - Use File::Temp and Path::Class in t/04webid.t - they're already dependencies, so might as well. ++"Kjetil Kjernsmo" 1.910_03 2012-05-09 - Better hooks for subclassing Plack::Middleware::Auth::WebID. 1.910_02 2012-05-08 - (Documentation) Add Any::Moose stuff to Web::ID BUGS section. ++"Florian Ragwitz" - (Documentation) Improve Web::ID DESCRIPTION. ++"Jonas Smedegaard" - (Update) Replace deprecated Digest::SHA1 with Digest::SHA. ++"Jonas Smedegaard" 1.910_01 2012-05-07 - Almost complete rewrite of CGI::Auth::FOAF_SSL. Very different (and much cleaner) API.