#
use strict;
package NB::CGI;
-#our $PARAM_UTF8 = 1 unless defined $PARAM_UTF8;
-#use CGI qw(-utf8);
use parent qw/CGI/;
-#use base qw/CGI/;
-#our @EXPORT_OK = @CGI::EXPORT_OK;
-#our @EXPORT = @CGI::EXPORT;
-#our @EXPORT= @CGI::EXPORT;
-#our @EXPORT_OK = @CGI::EXPORT_OK;
-# NB 01.12.23 BEGIN {
- # NB 01.12.23 require CGI;
- # NB 01.12.23 our @ISA;
- # NB 01.12.23 push @ISA, qw(CGI);
-# NB 01.12.23 }
$CGI::PARAM_UTF8 = 1;
-#$CGI::PARAM_UTF8 = 1 unless defined $CGI::PARAM_UTF8;
-#&CGI::init;
-# NB 01.12.23 &CGI::charset('utf-8') if $CGI::PARAM_UTF8;
-my $NO_HEADERS = 0;
-my $TEXT_OUTPUT = 0;
+our $DefaultClass = 'NB::CGI';
+our $Q;
+our $NO_HEADERS = 0;
+our $TEXT_OUTPUT = 0;
+
+if (1) { # NB 06.12.23: infinite loop
+ no warnings 'redefine';
+ no warnings 'once';
+ *CGI::_tag_func = \&_tag_func; # now CGI handle text mode
+};
+sub _new {
+ my($package,$interface,$boundary,$length) = @_;
+ my $self = {};
+ my $retval = bless $self,ref $package || $package;
+ return $retval;
+}
sub new {
my $cgi = &CGI::new(@_);
#$cgi->_setup_symbols;
return $cgi;
}
-sub textOutput {{
- no warnings 'redefine';
- no warnings 'once';
- #return unless $Opt{html};
-
- $TEXT_OUTPUT = 1;
- $CGI::CRLF = '';
- *CGI::_tag_func = sub {
- my $tagname = shift;
- my ($q,$a,@rest) = CGI::self_or_default(@_);
-
- #return "$a\t" if ref($a) eq '' and $a; # LABEL
- #warn $tagname; return '';
-
- my($attr) = '';
- my %attr;
- if (ref($a) && ref($a) eq 'HASH') {
- my(@attr) = CGI::make_attributes($a,$q->{'escape'});
- %attr = %$a;
- $attr = " @attr" if @attr;
- } else {
- unshift @rest,$a if defined $a;
- }
-
- $tagname = lc( $tagname );
- my @result = (ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest";
-
- #warn Dumper(\%attr) if $tagname eq 'a';;
- if (exists $attr{cgi_text})
- {
- @result = ($attr{cgi_text},"\n") if $attr{cgi_text};
- }
- # H.
- elsif ($tagname =~ /^h(\d+)$/)
- {
- @result = map {"$_\n";} @result;
- }
- # TH
- elsif ($tagname eq 'th')
- {
- @result = map {$_ ? "$_\n" : '';} @result;
- }
- # TD
- elsif ($tagname =~ /^(start_)?td$/)
- {
- #warn $tagname if ($tagname =~ /^(start_)?td$/);
- @result = map {"|$_";} @result;
- }
- # IFRAME
- elsif ($tagname eq 'iframe')
- {
- @result = map {$_ ? "$_\n" : '';} @result;
- @result = ('[ '.$a->{src}.' ]') if ref($a)||'' eq 'HASH';
- }
-
- @result = grep {$_ ne ' '} @result;
- return "@result";
- };
- *CGI::start_TR = sub { return "" };
- *CGI::end_TR = sub { return "|\n" };
- *CGI::button = sub { '' };
- *CGI::checkbox = sub { '' };
- *CGI::start_html = sub { '' };
- *CGI::end_html = sub { '' };
- *CGI::popup_menu = sub {
- my($self,@p) = CGI::self_or_default(@_);
- use Data::Dumper;
- #die Dumper(\@p);
- my(@values);
- #for (@p)
- while (@p)
- {
- $_ = shift @p;
- #warn ">>>$_"; next;
- next unless $_ eq '-labels';
- #die 'zaza';
- my $labels = shift @p;
- @values = map {$labels->{$_}."\t".$_} keys %$labels;
- last;
- }
- return map {"$_\n"} @values;
-
- };
-}}
+# NB 06.12.23 sub textOutput {
+ # NB 06.12.23 $TEXT_OUTPUT = 1;
+ # NB 06.12.23 $CGI::CRLF = '';
+# NB 06.12.23 {
+ # NB 06.12.23 no warnings 'redefine';
+ # NB 06.12.23 no warnings 'once';
+# NB 06.12.23 }
+# NB 06.12.23 }
sub header_status {
my %status_codes = (
530 => "Site is frozen",
599 => "Network connect timeout error",
);
- return "" if $NO_HEADERS;
- my($self,@p) = &CGI::self_or_default(@_);
+ return "" if $NO_HEADERS;
+ my($self,@p) = &self_or_default(@_);
my $status = shift @p;
return '' unless $status;
- #die $status;
- #die $status_codes{$status};
- $status = $status." ".$status_codes{$status} if $status_codes{$status};
- return ($ENV{SERVER_PROTOCOL}||'HTTP/1.1')." $status\r\n";
+ #die $status;
+ #die $status_codes{$status};
+ $status = $status." ".$status_codes{$status} if $status_codes{$status};
+ return ($ENV{SERVER_PROTOCOL}||'HTTP/1.1')." $status\r\n";
}
sub args2hash {
- my @p = @_;
- my %hash;
- #warn join('|',@p);
+ my @p = @_;
+ my %hash;
+ #warn join('|',@p);
- for (my $i=0;$i<@p-1;$i++)
- {
+ for (my $i=0;$i<@p-1;$i++)
+ {
#next if index($p[$i], '-') == -1;
next if $p[$i] !~ /^-(.*)$/;
$hash{$1} = $p[$i+1];
#warn $1."=".$hash{$1};
- }
+ }
- return wantarray ? %hash : \%hash;
+ return wantarray ? %hash : \%hash;
}
sub argsAdd {
- my $p = shift;
- my $key = shift; $key = "-$key";
- my $val = shift;
+ my $p = shift;
+ my $key = shift; $key = "-$key";
+ my $val = shift;
- # Delete existing
- for (my $i=0;$i<@$p-1;$i++)
- {
+ # Delete existing
+ for (my $i=0;$i<@$p-1;$i++)
+ {
next if $p->[$i] ne $key;
splice(@$p,$i,2);
- }
+ }
- # Add new one
- #push(@$p,$key,$val);
- unshift(@$p,$key,$val);
- return &args2hash(@$p);
+ # Add new one
+ #push(@$p,$key,$val);
+ unshift(@$p,$key,$val);
+ return &args2hash(@$p);
+}
+
+sub no_headers {
+ my($self,@p) = &self_or_default(@_);
+ my $no_header_sav = $NO_HEADERS;
+ $NO_HEADERS = $p[0] if @p;
+ return $no_header_sav;
}
sub header {
- return "" if $NO_HEADERS;
- my($self,@p) = &CGI::self_or_default(@_);
- my %p = &args2hash(@p);
- #&argsAdd(\@p,'expires',-1) unless $p{expires};
- # Cache-Control: private, no-cache, no-store, must-revalidate, post-check=0, pre-check=0
- $p{expires} ||= 0;
- if ($p{expires} =~ /^\d+$/ and $p{expires} <=0)
- {
- %p = &argsAdd(\@p,'Cache-Control','private, no-cache, no-store, must-revalidate, post-check=0, pre-check=0');
- %p = &argsAdd(\@p,'Pragma','no-cache');
- %p = &argsAdd(\@p,'expires','now');
- #&CGI::cache(0); # we dont want doubles headers
- }
- #warn join('|',@p);
- #warn join('|',keys(%p));
- #die join('|',keys(%p));
- #die $p{expires};
- my $status = '';
-
- if (!&CGI::nph())
- {
- for (my $i=0;$i<@p-1;$i++)
- {
+ return "" if $NO_HEADERS;
+ my($self,@p) = &self_or_default(@_);
+ my %p = &args2hash(@p);
+ #&argsAdd(\@p,'expires',-1) unless $p{expires};
+ # Cache-Control: private, no-cache, no-store, must-revalidate, post-check=0, pre-check=0
+ $p{expires} ||= 0;
+ if ($p{expires} =~ /^\d+$/ and $p{expires} <=0)
+ {
+ %p = &argsAdd(\@p,'Cache-Control','private, no-cache, no-store, must-revalidate, post-check=0, pre-check=0');
+ %p = &argsAdd(\@p,'Pragma','no-cache');
+ %p = &argsAdd(\@p,'expires','now');
+ #&CGI::cache(0); # we dont want doubles headers
+ }
+ #warn join('|',@p);
+ #warn join('|',keys(%p));
+ #die join('|',keys(%p));
+ #die $p{expires};
+ my $status = '';
+
+ if (!&CGI::nph())
+ {
+ for (my $i=0;$i<@p-1;$i++)
+ {
next if $p[$i] ne '-status';
$status = $p[$i+1];
splice(@p,$i,2);
- }
- }
-
- my @head = ();
- push @head,&CGI::header(@p);
- if ($status and @head and !&CGI::nph)
- {
- $status = $self->header_status($status);
- $status =~ s/\s+$//;
- unshift @head,$status;
- }
- return join($CGI::CRLF,@head);
+ }
+ }
+
+ my @head = ();
+ push @head,&CGI::header(@p);
+ if ($status and @head and !&CGI::nph)
+ {
+ $status = $self->header_status($status);
+ $status =~ s/\s+$//;
+ unshift @head,$status;
+ }
+ return join($CGI::CRLF,@head);
}
# NB 01.12.23 sub init {
# NB 01.12.23 &CGI::init(@_);
# NB 01.12.23 }
-sub start_html {
- local $_ = &CGI::start_html(@_);
- s/<!DOCTYPE .*?>/<!DOCTYPE html>/s;
- return $_;
+sub text {
+ my($self,@p) = &self_or_default(@_);
+ if (@p)
+ {
+ $TEXT_OUTPUT = $p[0];
+ # NB 06.12.23 &textOutput if $TEXT_OUTPUT;
+ }
+ return $TEXT_OUTPUT;
+}
+
+sub tag {
+ shift if ref($_[0]) eq __PACKAGE__; # _tag_func first arg must be tagname
+ return &_tag_func(@_);
+}
+
+sub _tag_func_ {
+ #warn 'TEXT' if $TEXT_OUTPUT;
+ return &text__tag_func(@_) if $TEXT_OUTPUT;
+ shift if ref($_[0]) eq __PACKAGE__; # for case: $cgi->_tag_func
+ return &CGI::_tag_func(@_);
}
sub _tag_func {
- shift if ref($_[0]) eq __PACKAGE__; # for case: $cgi->_tag_func
- return &CGI::_tag_func(@_);
+ return &text__tag_func(@_) if $TEXT_OUTPUT;
+ my $tagname = shift;
+ my ($q,$a,@rest) = self_or_default(@_);
+
+ my($attr) = '';
+
+ if (ref($a) && ref($a) eq 'HASH') {
+ my(@attr) = CGI::make_attributes($a,$q->{'escape'});
+ $attr = " @attr" if @attr;
+ } else {
+ unshift @rest,$a if defined $a;
+ }
+
+ $tagname = lc( $tagname );
+
+ if ($tagname=~/start_(\w+)/i) {
+ return "<$1$attr>";
+ } elsif ($tagname=~/end_(\w+)/i) {
+ return "</$1>";
+ } else {
+ return $CGI::XHTML ? "<$tagname$attr />" : "<$tagname$attr>" unless @rest;
+ my($tag,$untag) = ("<$tagname$attr>","</$tagname>");
+ my @result = map { "$tag$_$untag" }
+ (ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest";
+ return "@result";
+ }
}
-sub no_headers {
- my($self,@p) = &CGI::self_or_default(@_);
- my $no_header_sav = $NO_HEADERS;
- $NO_HEADERS = $p[0] if @p;
- return $no_header_sav;
+sub text__tag_func {
+ my $self; ($self,@_) = &self_or_default(@_);
+ my $tagname = shift;
+ my ($q,$a,@rest) = self_or_default(@_);
+
+ my($attr) = '';
+ my %attr;
+ if (ref($a) && ref($a) eq 'HASH') {
+ my(@attr) = CGI::make_attributes($a,$q->{'escape'});
+ %attr = %$a;
+ $attr = " @attr" if @attr;
+ } else {
+ unshift @rest,$a if defined $a;
+ }
+
+ $tagname = lc( $tagname );
+ my @result = (ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest";
+
+ if (exists $attr{cgi_text})
+ {
+ #print(">>".$tagname.$attr{cgi_text}."\n");
+ @result = ($attr{cgi_text},"\n") if $attr{cgi_text};
+ }
+ # H.
+ elsif ($tagname =~ /^h(\d+)$/)
+ {
+ @result = map {"$_\n";} @result;
+ }
+ # TH
+ elsif ($tagname eq 'th')
+ {
+ @result = map {$_ ? "$_\n" : '';} @result;
+ }
+ # TD
+ elsif ($tagname =~ /^(start_)?td$/)
+ {
+ @result = map {"|$_";} @result;
+ }
+ # IFRAME
+ elsif ($tagname eq 'iframe')
+ {
+ @result = map {$_ ? "$_\n" : '';} @result;
+ @result = ('[ '.$a->{src}.' ]') if ref($a)||'' eq 'HASH';
+ }
+
+ @result = grep {$_ ne ' '} @result;
+ return "@result";
}
-sub tag {
- return &_tag_func(@_);
+sub start_html {
+ return "" if $TEXT_OUTPUT;
+ #my($self,@p) = self_or_default(@_);
+ #local $_ = &CGI::start_html(@p);
+ local $_ = &CGI::start_html(@_);
+ s/<!DOCTYPE .*?>/<!DOCTYPE html>/s;
+ return $_;
+}
+#sub div { return &tag(@_) }
+sub end_html { return "" if $TEXT_OUTPUT; return &CGI::end_html(@_); }
+sub start_TR { return "" if $TEXT_OUTPUT; return &CGI::start_TR(@_); }
+sub end_TR { return "|\n" if $TEXT_OUTPUT; return &CGI::end_TR(@_); }
+sub button { return "" if $TEXT_OUTPUT; return &CGI::button(@_); }
+sub checkbox { return "" if $TEXT_OUTPUT; return &CGI::checkbox(@_); }
+sub popup_menu { return &text_popup_menu(@_) if $TEXT_OUTPUT; return &CGI::popup_menu(@_); }
+sub text_popup_menu {
+ my($self,@p) = self_or_default(@_);
+ #use Data::Dumper; die Dumper(\@p);
+ my(@values);
+ #for (@p)
+ while (@p)
+ {
+ $_ = shift @p;
+ #warn ">>>$_"; next;
+ next unless $_ eq '-labels';
+ #die 'zaza';
+ my $labels = shift @p;
+ @values = map {$labels->{$_}."\t".$_} keys %$labels;
+ last;
+ }
+ return map {"$_\n"} @values;
}
-sub text {
- return $TEXT_OUTPUT;
+sub self_or_default {
+ #return CGI::self_or_default(@_);
+ return @_ if defined($_[0]) && (!ref($_[0])) && ($_[0] eq 'NB::CGI');
+ #die 'zaza';
+ #warn 'zaza';
+ unless (defined($_[0]) &&
+ (ref($_[0]) eq 'NB::CGI' || UNIVERSAL::isa($_[0],'NB::CGI')) # slightly optimized for common case
+ )
+ {
+ $Q = $DefaultClass->new unless defined($Q);
+ unshift(@_,$Q);
+ }
+ return wantarray ? @_ : $Q;
}
+
+# NB 06.12.23 sub _self_or_CGI {
+ # NB 06.12.23 local $^W=0; # prevent a warning
+ # NB 06.12.23 if (defined($_[0]) && (substr(ref($_[0]),0,3) eq 'NB::CGI' || UNIVERSAL::isa($_[0],'NB::CGI'))) {
+ # NB 06.12.23 return @_;
+ # NB 06.12.23 } else {
+ # NB 06.12.23 return ($DefaultClass,@_);
+ # NB 06.12.23 }
+# NB 06.12.23 }
+
1;
projects / nb.git / commitdiff