view release on metacpan or  search on metacpan

build/global/global.asa  view on Meta::CPAN

    
    $ASP = { name => 'ASP', stack => [], level => 0};
    my @levels;
    unshift(@levels, $ASP);
    
    my $count = 0;
    my $level = 0;
    my $time = Time::HiRes::time;
    $data =~ s/\n=(over|back|begin|end)[^\n]*\n/\n/sg;
    while($data =~ s/^.*?\n=(head\d|item) ([^\n]*)\n(.*?)(\n\=|$)/$4/is) {
	my($type, $name, $body) = ($1,$2,$3);
	$body =~ s/\s+$//s;

	$name = $ALIASES{$name} || $name;
	# warn time." ----------- $type :: $name :: $body ----------- \n\n";
	#    warn substr($data, 0, 200)."\n";
	#    $body =~ s/\n=over\s*$//s;
	my $item = { 
		    name => $name,
		    unique => substr($name, 0, 12).(length($name) > 12 ? substr(md5_hex($name.$body),0,8) : ''),
		    body => $body,
		    stack => [],
		    level => ($level + 1),
		   };
	
	if($type =~ /^head(\d)/) {
	    my $current = $1;		
	    $item->{level} = $current;
#	    dbg("$current current level $name");
	    while($current <= $levels[0]->{level}) {
#		dbg("shifting $levels[0]->{name}");
		shift(@levels);
	    }
	    push(@{$levels[0]->{stack}}, $item);
#	    dbg("$level unshifting $item->{name}");
	    unshift(@levels, $item);
	    $level = $item->{level};
	} else {
	    push(@{$levels[0]->{stack}}, $item);	
	}

#	last if $count++ > 20;
    }

#    warn(Time::HiRes::time - $time);
    open(DUMP, ">$DUMP");
    print DUMP Data::Dumper->Dump([{ checksum => $new_checksum, ASP => $ASP}]);
    close DUMP;
    
    dbg(dmp($ASP));
}

sub pod2html {
    my($body, $title, $depth) = @_;

    if($title) {
	$depth ||= 1;
	my $size = 2 - $depth;
	$size = ($size > -1) ? "+$size" : $size;
	
	$title = "<font class=title size=$size color=#555555><b>$title</b></font>\n";
    }

    if (($body =~ /^(.*?)(<(a|table)[^\<\>]*>.*?<\/(\3)>)(.*)$/is)) {
	my($pre,$html,$post) = ($1, $2, $5);
#	$html =~ s/\s+/ /isg;
	$body = $Server->HTMLEncode($pre).$html.$Server->HTMLEncode($post);
    } else {
	$body = $Server->HTMLEncode($body);
    }
    $body =~ s/(\<\%|\%\>)/$Server->HTMLEncode($1);/esg;

    my @lines = split(/\n/, $body);
    my $pre = 0;
    my @newlines;
    for(@lines) {
	my $pre_tag = '';
	if(/^\s+[^\s]/ || /^\s*$/) {
	    if(! $pre) {
		#			$_ = "<pre>$_";
		$pre_tag = "<font face=\"courier new\" size=3><pre>";
		$pre = 1;
	    }
	} else {
	    if($pre) {
		#			$_ = "</pre>$_";	
		$pre_tag = "</pre></font>";
		$pre = 0;
	    }
	}
#	if($pre) {
#	$_ =~ s/\s*$//;
#	    $_ = $Server->HTMLEncode($_);	    
#	}

#	} 

	$_ = $pre_tag . $_;
	push(@newlines, $_);
    }
    $body = join("\n", @newlines);
    $pre and $body .= "\n</pre>";

    $body =~ s,\n\s+(([^:\n\s]{5}|[A-Z])[^\n]*?)\s*\n\s+(http://[^\n\s]+)\s*?\n,\n  <a href="$3">$1</a>\n,sg;
#print STDERR $body;

    #$body =~ s/\n\s*\n+/<p>/isg;
    $body =~ s/([^\=\"])((http|ftp):\/\/[\w\.\/\-]+\.[\w\.\/\-\#\,\%]+[^\.\s\)])/$1<a href=$2>$2<\/a>/sg;
#    $1 && warn "link: $1\n";
    $body =~ s|(http://localhost[\S]*[^\.\s\,]?)|<tt>$1</tt>|sg;
    $body =~ s|([\w\-]+\@[\w\.\,\@\-]+)(\?[\w\=\:]+)?|'<b>'.&html_encode_hide($1).'</b>'|esg;
    $body =~ s|(\./site/)(eg/[\w\.]+[^\.\s])|<a href=$2>$1$2</a>|sg;

    $body =~ s|\n\n</pre>|\n</pre>|isg;
#    my $match_links = join('|', keys %LINKS);

    my %matched;
    $body =~ s:([^\n]*?)\b($LINKS_MATCH)(?=[^<])\b:
    {
	my($head, $match) = ($1, $2);

#print STDERR "***** $head $match\n";
	if(! $matched{$match}++ and $head !~ /\>$/ and $head !~ /^\s+/ and $LINKS{$match}) {
	    "$head<a href=$LINKS{$match}><font size=-1 face=verdana><b>$match<\/b><\/font><\/a>";
	} else	 {
	    $head.$match;
	}
    }
    :sgex;

    '<font face=verdana>'.$title.$body.'</font>';
}

# we use this to mask email addresses in the documentation
sub html_encode_hide {
    my $word = shift;
    join('',
	 map{
	     sprintf(qq(&#%03d;),ord($_))
	 } split(//, $word)
	);
}