lib/SmartLink.pm

   1 package SmartLink;
   2 use Moose;
   3 use Moose::Util::TypeConstraints;
   4
   5 ## links are like
   6 # L<doc> or L<doc/section> or L<doc/section/keyphrases>
   7 subtype PodLink => as Str => where { m|^L<([^/]+)(\/([^/]+)){0,2}>| };
   8
   9 has 'link' => ( is => 'ro', isa => 'PodLink', required => 1, );
  10
  11 has 'doc' => (
  12     is => 'ro', isa => 'Doc',
  13     lazy => 1, default => sub{
  14         ($_)= shift->link =~ m|^L<([^/]+)|;
  15         Doc->new( id => $_ )
  16     },
  17 );
  18
  19 has 'section' => (
  20     is => 'ro', isa => 'Str',
  21     lazy => 1, default => sub{
  22         ($_)= shift->link =~ m|^L<.*?/([^/]+)[/>]|;
  23         length $_
  24             or die qq{'section' can't be empty!\n} ;
  25         $_
  26     },
  27     predicate => 'has_section',
  28 );
  29
  30 has 'keyphrases' => (
  31     is => 'ro', isa => 'Keyphrase',
  32     predicate => 'has_keyphrases',
  33 );
  34
  35 sub BUILD { # Set a value for keyphrases *only* if there is any
  36     my $self = shift;
  37     my ($keyphrase)= $self->link =~ m|^L<.*?/.*?/([^>]+)>|;
  38     $self->meta->find_attribute_by_name("keyphrases")->set_value(
  39         $self, Keyphrase->new(string => $keyphrase),
  40     ) if defined $keyphrase;
  41     return;
  42 }
  43
  44 package Doc;
  45 use Moose;
  46
  47 has 'id' => ( is => 'ro', isa => 'Str', required => 1, );
  48
  49 has 'prefix' => (
  50     is => 'ro', isa => 'Str',
  51     lazy => 1, default => sub{
  52         ($_)= shift->id =~ m|^(\D+)|; $_
  53     },
  54 );
  55
  56 has 'num' => (
  57     is => 'ro', isa => 'Str',
  58     lazy => 1, default => sub{
  59         ($_)= shift->id =~ m|(\d+)$|; $_
  60     },
  61 );
  62
  63
  64 package Keyphrase;
  65 use Moose;
  66 use Text::Balanced qw/extract_multiple extract_quotelike/;
  67
  68 has 'string' => ( is => 'ro', isa => 'Str', required => 1, );
  69
  70 has 'list' => (
  71     is => 'ro', isa => 'ArrayRef',
  72     lazy => 1, default => sub{
  73         my $string= shift->string;
  74         [
  75             extract_multiple($string, [
  76                 sub{
  77                     do{
  78                         my @a= (extract_quotelike($string))[5,1];
  79                         $string= $a[1]; $a[0];
  80                     } or do{
  81                         my @a= split ' ', $_[0], 2;
  82                         $string= $a[1]; $a[0];
  83                     }
  84                 },
  85             ])
  86         ]
  87     },
  88 );
  89
  90 has 'regex' => (
  91     is => 'ro', isa => 'Str',
  92     lazy => 1, default => sub{
  93         my $self= shift;
  94         join '.+?' => map {
  95             my $key= quotemeta $_;
  96             $key =~ s/^\w/\\b$&/;
  97             $key =~ s/\w$/$&\\b/;
  98             $key;
  99         } @{$self->list};
 100     },
 101 );
 102
 103
 104 package File;
 105 use Moose;
 106 use File::Basename qw/fileparse/;
 107
 108 has 'filename' => ( is => 'ro', isa => 'Str', required => 1, );
 109
 110 has 'name' => (
 111     is => 'ro', isa => 'Str',
 112     lazy => 1, default => sub{
 113         my $self= shift;
 114         (fileparse($self->filename, $self->extension))[0]
 115     },
 116 );
 117
 118 has 'path' => (
 119     is => 'ro', isa => 'Str',
 120     lazy => 1, default => sub{
 121         my $self= shift;
 122         (fileparse($self->filename, $self->extension))[1]
 123     },
 124 );
 125
 126 has 'extension' => (
 127     is => 'ro', isa => 'Str',
 128     lazy => 1, default => sub{
 129         my $self= shift;
 130         ($_)= $self->filename =~ m|^.*?(\..*)$|; $_
 131     },
 132 );
 133
 134 has 'filehandle' => ( is => 'ro', isa => 'FileHandle', );
 135 has 'mode' => ( is => 'ro', isa => 'Str', );
 136
 137 sub open {
 138     my $self= shift;
 139     my( $mode )= @_;
 140     open $self->{filehandle}, $mode => $self->filename
 141         or die qq{can't open } . $self->filename . qq{: $!};
 142     $self->{mode}= $mode;
 143     $self->filehandle
 144 }
 145
 146 sub close { }
 147
 148
 149 package PodFile;
 150 use Moose;
 151 use Moose::Util::TypeConstraints;
 152 extends 'File';
 153
 154 override 'extension' => sub{ '.pod' };
 155
 156 has 'tree' => (
 157     is => 'rw', isa => 'HashRef',
 158     lazy => 1, default => sub {
 159         my $self= shift;
 160
 161         my $in= $self->open( '<' );
 162
 163         my $tree= {};
 164         my $section;
 165         while( <$in> ) {
 166             if( /(?x) ^ =head (\d+) \s* (.*\S) \s* $/ ) {
 167                 my $num= $1;
 168                 $section= $2;
 169                 $tree->{_sections} ||= [];
 170                 push @{ $tree->{_sections} } => [$num, $section];
 171             } elsif (!$section) {
 172                 $tree->{_header} .= $_;
 173             } elsif (/^\s*$/) {
 174                 $tree->{$section} ||= [];
 175                 push @{ $tree->{$section} }, '';
 176             } elsif (/^\s+(.+)/) {
 177                 $tree->{$section}->[-1] .= $_;
 178                 push @{ $tree->{$section} }, '';
 179             } else {
 180                 $tree->{$section}->[-1] .= $_;
 181             }
 182         }
 183         close $in;
 184         $tree;
 185     },
 186 );
 187
 188 sub parse { shift->tree }
 189
 190
 191 package SpecFile;
 192 use Moose;
 193 extends 'PodFile';
 194
 195 has 'prefix' => ( is => 'ro', isa => 'Str', required => 1, );
 196
 197 has 'num' => (
 198     is => 'ro', isa => 'Str',
 199     lazy => 1, default => sub{
 200         my $self= shift;
 201         my $pre= $self->prefix;
 202         ($_)= $self->name =~ m|$pre(\d+).*$|; $_ || ''
 203     },
 204 );
 205
 206
 207 package SpecFiles;
 208 use Moose;
 209 use Moose::Util::TypeConstraints;
 210 use File::Spec::Functions qw/catfile/;
 211
 212 has 'root' => ( is => 'ro', isa => 'Str', required => 1, );
 213 has 'extension' => ( is => 'ro', isa => 'Str', default => '.pod' );
 214 has 'prefix' => ( is => 'ro', isa => 'Str', required => 1, );
 215
 216 has 'files' => (
 217     is => 'ro', isa => subtype( 'ArrayRef'
 218         => where { (blessed($_) && $_->isa('PodFile') || return) for @$_; 1 } ),
 219     lazy => 1, default => sub{
 220         my $self= shift;
 221         [ map { SpecFile->new( filename => $_, prefix => $self->prefix  ) }
 222             glob catfile( $self->root, $self->prefix . '*' . $self->extension )]
 223     },
 224 );
 225
 226
 227 package TestFile;
 228 use Moose;
 229 use Moose::Util::TypeConstraints;
 230 extends 'File';
 231
 232 override 'extension' => sub{ '.t' };
 233
 234 has 'smartlinks' => (
 235     is => 'rw', isa => subtype 'ArrayRef'
 236         => where { (blessed($_) && $_->isa('SmartLink') || return) for @$_; 1 },
 237 );
 238
 239 has 'tests' => (
 240     is => 'rw', isa => subtype 'ArrayRef'
 241         => where { (blessed($_) && $_->isa('TestInfo') || return) for @$_; 1 },
 242 );
 243
 244
 245 package Test;
 246 use Moose;
 247 use Moose::Util::TypeConstraints;
 248
 249 subtype TestStatus => as Str => where { m/^(not)? ok$/ };
 250
 251 has 'file' => ( is => 'ro', isa => 'TestFile', required => 1, );
 252 has 'number' => ( is => 'ro', isa => 'Int', required => 1, );
 253 has 'status' => ( is => 'ro', isa => 'TestStatus', required => 1, );
 254 has 'description' => ( is => 'ro', isa => 'Str' );
 255
 256
 257 package TestInfo;
 258 use Moose;
 259
 260 has 'test' => ( is => 'ro', isa => 'Test', required => 1, );
 261 has 'line' => ( is => 'ro', isa => 'Int', required => 1, );
 262
 263
 264 package SmartLinkServer;
 265 use Moose;
 266 use Moose::Util::TypeConstraints;
 267
 268 has 'specmap' => (
 269     is => 'ro', isa => 'HashRef', default => sub{ {
 270         'PDD' => {reverse qw(
 271             00 pdd          01 overview    02 vtables   03 calling_conventions
 272             04 datatypes    05 opfunc      06 pasm      07 codingstd
 273             08 keys         09 gc          10 embedding 11 extending
 274             12 assembly     13 bytecode    14 bignum    15 objects
 275             16 native_call  17 basic_types 18 security  19 pir
 276             20 lexical_vars 21 namespaces  22 io        23 exceptions
 277             24 events       25 concurrency
 278         )},
 279         'S' => {reverse qw(
 280             01 Overview 02 Syntax        03 Operator     04 Block
 281             05 Rule     06 Subroutine    09 Structure    10 Package
 282             11 Module   12 Object        13 Overload     17 Concurrency
 283             22 CPAN     26 Documentation 29 Functions
 284         )},
 285     }},
 286 );
 287
 288 has 'jscode' => (
 289     is => 'ro', isa => 'Str', default => sub{ <<'_EOC_';
 290 <script type="text/javascript">
 291 var agt = navigator.userAgent.toLowerCase();
 292
 293 var is_opera = (agt.indexOf("opera") != -1);
 294 var is_ie = (agt.indexOf("msie") != -1) && document.all && !is_opera;
 295 var is_ie5 = (agt.indexOf("msie 5") != -1) && document.all;
 296
 297 function tog() {
 298   // tog: toggle the visibility of html elements (arguments[1..]) from none to
 299   // arguments[0].  Return what should be returned in a javascript onevent().
 300   display = arguments[0];
 301   for( var i=1; i<arguments.length; i++ ) {
 302     var x = document.getElementById(arguments[i]);
 303     if (!x) continue;
 304     if (x.style.display == "none" || x.style.display == "") {
 305       x.style.display = display;
 306     } else {
 307       x.style.display = "none";
 308     }
 309   }
 310
 311   var e = is_ie ? window.event : this;
 312   if (e) {
 313     if (is_ie) {
 314       e.cancelBubble = true;
 315       e.returnValue = false;
 316       return false;
 317     } else {
 318       return false;
 319     }
 320   }
 321 }
 322
 323 function tog_quote( idnum ) {
 324   return tog( 'block', 'header_shown_' + idnum, 'header_hidden_' + idnum,
 325        'hide_' + idnum );
 326 }
 327
 328 </script>
 329 _EOC_
 330     },
 331 );
 332
 333 ## XXX: works for me, probably not for all
 334 has 'specroot' => (
 335     is => 'rw', isa => 'HashRef',
 336     default => sub{
 337         { PDD => 'docs/pdds', S => '../../perl6/doc/trunk/design/syn' }
 338     },
 339 );
 340
 341 has 'specfiles' => (
 342     is => 'ro', isa => subtype( 'HashRef'
 343         => where {
 344             for my $key ( keys %$_ ) {
 345                 return unless blessed($$_{$key})
 346                     && $$_{$key}->isa('SpecFiles')
 347                     && $$_{$key}->prefix eq $key;
 348             }
 349             1
 350         },
 351     ),
 352     lazy => 1, default => sub{
 353         my $self= shift;
 354         my %hash;
 355         for( keys %{ $self->specroot } ) {
 356             $hash{$_}= SpecFiles->new(
 357                 prefix => $_, root => ${ $self->specroot }{$_}
 358             );
 359         }
 360         \%hash
 361     },
 362 );
 363
 364 has 'testfiles' => (
 365     is => 'ro', isa => subtype( 'ArrayRef'
 366         => where { (blessed($_) && $_->isa('TestFile') || return) for @$_; 1 }
 367     ),
 368     lazy => 1, default => sub{
 369         my $self= shift;
 370         [ map { TestFile->new( filename => $_ ) } <@ARGV> ]
 371     },
 372 );
 373
 374 has 'linktree' => (
 375     is => 'ro', isa => 'LinkTree',
 376     lazy => 1, default => sub{
 377         my $self= shift;
 378         my $tree= LinkTree->new;
 379
 380         for my $file (@{$self->testfiles}) {
 381             my $in= $file->open( '<' );
 382
 383             my( $setter, $from, $to );
 384             my $link;
 385             while(<$in>) {
 386                 chomp;
 387                 my $new_from;
 388                 if( /^ \s* \#+? \s* (L<.*>) \s* $/xo ) {
 389                     $link= SmartLink->new( link => $1 );
 390                     $new_from = $.;
 391                     $to = $. - 1;
 392                 }
 393                 ## XXX: eliminated two-line smartlink for ease of implementation
 394                 else { next; }
 395
 396                 ## XXX: this logic seems contorted, nay, buggy
 397                 if ($from and $from == $to) {
 398                     my $old_setter = $setter;
 399                     my $old_from = $from;
 400                     $setter = sub {
 401                         $tree->add_link( $link, $file, $_[0], $_[1] );
 402                         $old_setter->($old_from, $_[1]);
 403                     };
 404                 } else {
 405                     $setter->($from, $to) if $setter and $from;
 406                     $setter = sub {
 407                         $tree->add_link($link, $file, $_[0], $_[1] );
 408                     };
 409                 }
 410                 $from = $new_from;
 411
 412                 $setter->( $from, $. ) if $setter and $from;
 413                 $file->close;
 414             }
 415         }
 416         $tree
 417     },
 418 );
 419
 420 has 'mergetree' =>(
 421     is => 'ro', isa => 'HashRef',
 422     lazy => 1, default => sub{
 423         my $self= shift;
 424         my $tree= {};
 425         for my $spectype ( keys %{ $self->specfiles } ) {
 426             my $specs= $self->specfiles_of_type( $spectype );
 427             $specs= $specs->files;
 428             for my $spec ( @$specs ) {
 429                 my $linkdoc= $self->linktree->get_doc( $spec->name );
 430                 warn $spec->name,$/; # XXX: FIXME: TODO:
 431                 next unless $linkdoc;
 432                 $spec->{_sections}++
 433             }
 434         }
 435         $tree
 436     },
 437 );
 438
 439 sub specfiles_of_type {
 440     my $self= shift;
 441     my( $type )= @_;
 442     $self->specfiles->{$type}
 443 }
 444
 445 sub emit {
 446     my $self= shift;
 447 }
 448
 449
 450 package LinkTree;
 451 use Moose;
 452
 453 has 'tree' => ( is => 'rw', isa => 'HashRef', default => sub{ {} }, );
 454
 455 has 'count' => ( is => 'rw', isa => 'Int', default => 0 );
 456
 457 sub inc_link_count { my $self= shift; $self->count( $self->count + 1 ); }
 458
 459 sub get_doc { return shift->{shift} }
 460
 461 sub get_link_doc {
 462     my $self= shift;
 463     my( $link )= @_;
 464     $self->tree->{$link->doc->id}
 465         if defined $self->tree->{$link->doc->id};
 466 }
 467
 468 sub get_link_section {
 469     my $self= shift;
 470     my( $link )= @_;
 471     my $doc= $self->get_link_doc( $link );
 472     $doc->{$link->section}
 473         if defined $doc and defined $doc->{$link->section};
 474 }
 475
 476 sub add_link_doc {
 477     my $self= shift;
 478     my( $link )= @_;
 479     $self->tree->{$link->doc->id}= {}
 480         unless $self->get_link_doc( $link );
 481 }
 482
 483 sub add_link_section {
 484     my $self= shift;
 485     my( $link )= @_;
 486     $self->add_link_doc( $link );
 487     my $doc= $self->get_link_doc( $link );
 488     $doc->{$link->section}= []
 489         unless defined $doc->{$link->section};
 490 }
 491
 492 sub add_link {
 493     my $self= shift;
 494     my( $link, $file, $from, $to )= @_;
 495     my $tree= $self->tree;
 496
 497     $self->add_link_section( $link );
 498     my $section= $self->get_link_section( $link );
 499
 500     push @$section => [
 501         $link->keyphrases->string,
 502         [ $file->name, $from, $to ],
 503     ];
 504     $self->inc_link_count;
 505     $tree
 506 }
 507
 508
 509 $_^=~ { AUTHOR => 'particle' };
 510
 511
 512 # Local Variables:
 513 #   mode: cperl
 514 #   cperl-indent-level: 4
 515 #   fill-column: 100
 516 # End:
 517 # vim: expandtab shiftwidth=4: