package SmartLink;
use Moose;
use Moose::Util::TypeConstraints;
## links are like
# L<doc> or L<doc/section> or L<doc/section/keyphrases>
subtype PodLink => as Str => where { m|^L<([^/]+)(\/([^/]+)){0,2}>| };
has 'link' => ( is => 'ro', isa => 'PodLink', required => 1, );
has 'doc' => (
is => 'ro', isa => 'Doc',
lazy => 1, default => sub{
($_)= shift->link =~ m|^L<([^/]+)|;
Doc->new( id => $_ )
},
);
has 'section' => (
is => 'ro', isa => 'Str',
lazy => 1, default => sub{
($_)= shift->link =~ m|^L<.*?/([^/]+)[/>]|;
length $_
or die qq{'section' can't be empty!\n} ;
$_
},
predicate => 'has_section',
);
has 'keyphrases' => (
is => 'ro', isa => 'Keyphrase',
default => sub{
($_)= shift->link =~ m|^L<.*?/.*?/([^>]+)>|;
defined $_ ? Keyphrase->new( string => $_ ) : undef;
},
predicate => 'has_keyphrases',
);
package Doc;
use Moose;
has 'id' => ( is => 'ro', isa => 'Str', required => 1, );
has 'prefix' => (
is => 'ro', isa => 'Str',
lazy => 1, default => sub{
($_)= shift->id =~ m|^(\D+)|; $_
},
);
has 'num' => (
is => 'ro', isa => 'Str',
lazy => 1, default => sub{
($_)= shift->id =~ m|(\d+)$|; $_
},
);
package Keyphrase;
use Moose;
use Text::Balanced qw/extract_multiple extract_quotelike/;
has 'string' => ( is => 'ro', isa => 'Str', required => 1, );
has 'list' => (
is => 'ro', isa => 'ArrayRef',
lazy => 1, default => sub{
my $string= shift->string;
[
extract_multiple($string, [
sub{
do{
my @a= (extract_quotelike($string))[5,1];
$string= $a[1]; $a[0];
} or do{
my @a= split ' ', $_[0], 2;
$string= $a[1]; $a[0];
}
},
])
]
},
);
has 'regex' => (
is => 'ro', isa => 'Str',
lazy => 1, default => sub{
my $self= shift;
join '.+?' => map {
my $key= quotemeta $_;
$key =~ s/^\w/\\b$&/;
$key =~ s/\w$/$&\\b/;
$key;
} @{$self->list};
},
);
package File;
use Moose;
use File::Basename qw/fileparse/;
has 'filename' => ( is => 'ro', isa => 'Str', required => 1, );
has 'name' => (
is => 'ro', isa => 'Str',
lazy => 1, default => sub{
my $self= shift;
(fileparse($self->filename, $self->extension))[0]
},
);
has 'path' => (
is => 'ro', isa => 'Str',
lazy => 1, default => sub{
my $self= shift;
(fileparse($self->filename, $self->extension))[1]
},
);
has 'extension' => (
is => 'ro', isa => 'Str',
lazy => 1, default => sub{
my $self= shift;
($_)= $self->filename =~ m|^.*?(\..*)$|; $_
},
);
has 'filehandle' => ( is => 'ro', isa => 'FileHandle', );
has 'mode' => ( is => 'ro', isa => 'Str', );
sub open {
my $self= shift;
my( $mode )= @_;
open $self->{filehandle}, $mode => $self->filename
or die qq{can't open } . $self->filename . qq{: $!};
$self->{mode}= $mode;
$self->filehandle
}
sub close { }
package PodFile;
use Moose;
use Moose::Util::TypeConstraints;
extends 'File';
override 'extension' => sub{ '.pod' };
has 'tree' => (
is => 'rw', isa => 'HashRef',
lazy => 1, default => sub {
my $self= shift;
my $in= $self->open( '<' );
my $tree= {};
my $section;
while( <$in> ) {
if( /(?x) ^ =head (\d+) \s* (.*\S) \s* $/ ) {
my $num= $1;
$section= $2;
$tree->{_sections} ||= [];
push @{ $tree->{_sections} } => [$num, $section];
} elsif (!$section) {
$tree->{_header} .= $_;
} elsif (/^\s*$/) {
$tree->{$section} ||= [];
push @{ $tree->{$section} }, '';
} elsif (/^\s+(.+)/) {
$tree->{$section}->[-1] .= $_;
push @{ $tree->{$section} }, '';
} else {
$tree->{$section}->[-1] .= $_;
}
}
close $in;
$tree;
},
);
sub parse { shift->tree }
package SpecFile;
use Moose;
extends 'PodFile';
has 'prefix' => ( is => 'ro', isa => 'Str', required => 1, );
has 'num' => (
is => 'ro', isa => 'Str',
lazy => 1, default => sub{
my $self= shift;
my $pre= $self->prefix;
($_)= $self->name =~ m|$pre(\d+).*$|; $_ || ''
},
);
package SpecFiles;
use Moose;
use Moose::Util::TypeConstraints;
use File::Spec::Functions qw/catfile/;
has 'root' => ( is => 'ro', isa => 'Str', required => 1, );
has 'extension' => ( is => 'ro', isa => 'Str', default => '.pod' );
has 'prefix' => ( is => 'ro', isa => 'Str', required => 1, );
has 'files' => (
is => 'ro', isa => subtype( 'ArrayRef'
=> where { (blessed($_) && $_->isa('PodFile') || return) for @$_; 1 } ),
lazy => 1, default => sub{
my $self= shift;
[ map { SpecFile->new( filename => $_, prefix => $self->prefix ) }
glob catfile( $self->root, $self->prefix . '*' . $self->extension )]
},
);
package TestFile;
use Moose;
use Moose::Util::TypeConstraints;
extends 'File';
override 'extension' => sub{ '.t' };
has 'smartlinks' => (
is => 'rw', isa => subtype 'ArrayRef'
=> where { (blessed($_) && $_->isa('SmartLink') || return) for @$_; 1 },
);
has 'tests' => (
is => 'rw', isa => subtype 'ArrayRef'
=> where { (blessed($_) && $_->isa('TestInfo') || return) for @$_; 1 },
);
package Test;
use Moose;
use Moose::Util::TypeConstraints;
subtype TestStatus => as Str => where { m/^(not)? ok$/ };
has 'file' => ( is => 'ro', isa => 'TestFile', required => 1, );
has 'number' => ( is => 'ro', isa => 'Int', required => 1, );
has 'status' => ( is => 'ro', isa => 'TestStatus', required => 1, );
has 'description' => ( is => 'ro', isa => 'Str' );
package TestInfo;
use Moose;
has 'test' => ( is => 'ro', isa => 'Test', required => 1, );
has 'line' => ( is => 'ro', isa => 'Int', required => 1, );
package SmartLinkServer;
use Moose;
use Moose::Util::TypeConstraints;
has 'specmap' => (
is => 'ro', isa => 'HashRef', default => sub{ {
'PDD' => {reverse qw(
00 pdd 01 overview 02 vtables 03 calling_conventions
04 datatypes 05 opfunc 06 pasm 07 codingstd
08 keys 09 gc 10 embedding 11 extending
12 assembly 13 bytecode 14 bignum 15 objects
16 native_call 17 basic_types 18 security 19 pir
20 lexical_vars 21 namespaces 22 io 23 exceptions
24 events 25 concurrency
)},
'S' => {reverse qw(
01 Overview 02 Syntax 03 Operator 04 Block
05 Rule 06 Subroutine 09 Structure 10 Package
11 Module 12 Object 13 Overload 17 Concurrency
22 CPAN 26 Documentation 29 Functions
)},
}},
);
has 'jscode' => (
is => 'ro', isa => 'Str', default => sub{ <<'_EOC_';
<script type="text/javascript">
var agt = navigator.userAgent.toLowerCase();
var is_opera = (agt.indexOf("opera") != -1);
var is_ie = (agt.indexOf("msie") != -1) && document.all && !is_opera;
var is_ie5 = (agt.indexOf("msie 5") != -1) && document.all;
function tog() {
// tog: toggle the visibility of html elements (arguments[1..]) from none to
// arguments[0]. Return what should be returned in a javascript onevent().
display = arguments[0];
for( var i=1; i<arguments.length; i++ ) {
var x = document.getElementById(arguments[i]);
if (!x) continue;
if (x.style.display == "none" || x.style.display == "") {
x.style.display = display;
} else {
x.style.display = "none";
}
}
var e = is_ie ? window.event : this;
if (e) {
if (is_ie) {
e.cancelBubble = true;
e.returnValue = false;
return false;
} else {
return false;
}
}
}
function tog_quote( idnum ) {
return tog( 'block', 'header_shown_' + idnum, 'header_hidden_' + idnum,
'hide_' + idnum );
}
</script>
_EOC_
},
);
## XXX: works for me, probably not for all
has 'specroot' => (
is => 'rw', isa => 'HashRef',
default => sub{
{ PDD => 'docs/pdds', S => '../../perl6/doc/trunk/design/syn' }
},
);
has 'specfiles' => (
is => 'ro', isa => subtype( 'HashRef'
=> where {
for my $key ( keys %$_ ) {
return unless blessed($$_{$key})
&& $$_{$key}->isa('SpecFiles')
&& $$_{$key}->prefix eq $key;
}
1
},
),
lazy => 1, default => sub{
my $self= shift;
my %hash;
for( keys %{ $self->specroot } ) {
$hash{$_}= SpecFiles->new(
prefix => $_, root => ${ $self->specroot }{$_}
);
}
\%hash
},
);
has 'testfiles' => (
is => 'ro', isa => subtype( 'ArrayRef'
=> where { (blessed($_) && $_->isa('TestFile') || return) for @$_; 1 }
),
lazy => 1, default => sub{
my $self= shift;
[ map { TestFile->new( filename => $_ ) } <@ARGV> ]
},
);
has 'linktree' => (
is => 'ro', isa => 'LinkTree',
lazy => 1, default => sub{
my $self= shift;
my $tree= LinkTree->new;
for my $file (@{$self->testfiles}) {
my $in= $file->open( '<' );
my( $setter, $from, $to );
my $link;
while(<$in>) {
chomp;
my $new_from;
if( /^ \s* \#+? \s* (L<.*>) \s* $/xo ) {
$link= SmartLink->new( link => $1 );
$new_from = $.;
$to = $. - 1;
}
## XXX: eliminated two-line smartlink for ease of implementation
else { next; }
## XXX: this logic seems contorted, nay, buggy
if ($from and $from == $to) {
my $old_setter = $setter;
my $old_from = $from;
$setter = sub {
$tree->add_link( $link, $file, $_[0], $_[1] );
$old_setter->($old_from, $_[1]);
};
} else {
$setter->($from, $to) if $setter and $from;
$setter = sub {
$tree->add_link($link, $file, $_[0], $_[1] );
};
}
$from = $new_from;
$setter->( $from, $. ) if $setter and $from;
$file->close;
}
}
$tree
},
);
has 'mergetree' =>(
is => 'ro', isa => 'HashRef',
lazy => 1, default => sub{
my $self= shift;
my $tree= {};
for my $spectype ( keys %{ $self->specfiles } ) {
my $specs= $self->specfiles_of_type( $spectype );
$specs= $specs->files;
for my $spec ( @$specs ) {
my $linkdoc= $self->linktree->get_doc( $spec->name );
warn $spec->name,$/; # XXX: FIXME: TODO:
next unless $linkdoc;
$spec->{_sections}++
}
}
$tree
},
);
sub specfiles_of_type {
my $self= shift;
my( $type )= @_;
$self->specfiles->{$type}
}
sub emit {
my $self= shift;
}
package LinkTree;
use Moose;
has 'tree' => ( is => 'rw', isa => 'HashRef', default => sub{ {} }, );
has 'count' => ( is => 'rw', isa => 'Int', default => 0 );
sub inc_link_count { my $self= shift; $self->count( $self->count + 1 ); }
sub get_doc { return shift->{shift} }
sub get_link_doc {
my $self= shift;
my( $link )= @_;
$self->tree->{$link->doc->id}
if defined $self->tree->{$link->doc->id};
}
sub get_link_section {
my $self= shift;
my( $link )= @_;
my $doc= $self->get_link_doc( $link );
$doc->{$link->section}
if defined $doc and defined $doc->{$link->section};
}
sub add_link_doc {
my $self= shift;
my( $link )= @_;
$self->tree->{$link->doc->id}= {}
unless $self->get_link_doc( $link );
}
sub add_link_section {
my $self= shift;
my( $link )= @_;
$self->add_link_doc( $link );
my $doc= $self->get_link_doc( $link );
$doc->{$link->section}= []
unless defined $doc->{$link->section};
}
sub add_link {
my $self= shift;
my( $link, $file, $from, $to )= @_;
my $tree= $self->tree;
$self->add_link_section( $link );
my $section= $self->get_link_section( $link );
push @$section => [
$link->keyphrases->string,
[ $file->name, $from, $to ],
];
$self->inc_link_count;
$tree
}
$_^=~ { AUTHOR => 'particle' };
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
syntax highlighted by Code2HTML, v. 0.9.1