adding bzip2 support in ruby

[biopieces.git] / code_perl / Maasha / XHTML.pm

diff --git a/code_perl/Maasha/XHTML.pm b/code_perl/Maasha/XHTML.pm
index 44a72ba182bbc161c0be688ae548833b7dd1e730..0992c7c258d6147e0b91066753912a0dbb6da3bc 100755 (executable)
--- a/code_perl/Maasha/XHTML.pm
+++ b/code_perl/Maasha/XHTML.pm
@@ -1,6 +1,6 @@
 package Maasha::XHTML;
 
-# Copyright (C) 2005 Martin A. Hansen.
+# Copyright (C) 2005-2010 Martin A. Hansen.
 
 # This program is free software; you can redistribute it and/or
 # modify it under the terms of the GNU General Public License
@@ -80,6 +80,48 @@ require Exporter;
 @ISA = qw( Exporter );
 
 
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> SIGNAL HANDLERS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+use sigtrap qw( die normal-signals stack-trace any error-signals );
+
+my $WARNINGS = 0;
+
+$SIG{ '__DIE__' }  = \&sig_die;
+$SIG{ '__WARN__' } = \&sig_warn;
+
+
+sub sig_die
+{
+    my ( $sig,   # signal from the %SIG
+       ) = @_;
+
+    my ( @html );
+
+    push @html, &cgi_header;
+    push @html, p( txt => "ERROR: $sig" );
+
+    $WARNINGS++;
+
+    print "$_" for @html;
+}
+
+
+sub sig_warn
+{
+    my ( $sig,   # signal from the %SIG
+       ) = @_;
+
+    my ( @html );
+
+    push @html, &cgi_header if $WARNINGS == 0;
+    push @html, p( txt => "WARNING: $sig" );
+
+    $WARNINGS++;
+
+    print "$_" for @html;
+}
+
+
 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> HEADERS <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 
 
@@ -96,7 +138,7 @@ sub html_header
 
     my ( @html );
 
-    push @html, &cgi_header                            if $args{ "cgi_header" };
+    push @html, &cgi_header                            if $args{ "cgi_header" } and $WARNINGS == 0;
     push @html, &doc_type;
     push @html, &head_beg;
     push @html, &title( $args{ "title" } )             if $args{ "title" };
@@ -734,6 +776,23 @@ sub map_end
 }
 
 
+sub area
+{
+    # Martin A. Hansen, October 2009.
+
+    # HTML <area> element
+
+    my ( %args,
+       ) = @_;
+
+    warn qq(WARNING: no area href given\n)    if not $args{ "href" };
+    warn qq(WARNING: no area shape given \n)  if not $args{ "shape" };
+    warn qq(WARNING: no area coords given \n) if not $args{ "coords" };
+
+    return tag_single( "area", \%args )
+}
+
+
 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> PRE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 
 
@@ -1583,4 +1642,34 @@ sub input_field
 }
 
 
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DEBUG <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+sub hdump
+{
+    # Martin A. Hansen, November 2009.
+    #
+    # Primitive debug routine that returns given data
+    # in <pre> tags as HTML lines.
+
+    my ( $data,   # data to dump
+       ) = @_;
+
+    # Returns a list
+
+    my ( @html );
+
+    @html = "Content-Type: text/html; charset=ISO-8859-1\n\n";
+
+    push @html, "<pre>\n";
+    push @html, Dumper( $data );
+    push @html, "</pre>\n";
+
+    return wantarray ? @html : \@html;
+}
+
+
 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+1;
+