From: Nicolas Boisselier <nicolas.boisselier@gmail.com>
Date: Wed, 6 Dec 2023 16:21:43 +0000 (+0100)
Subject: text mode
X-Git-Url: https://git.nbdom.net/?a=commitdiff_plain;h=8b316cc4c8c8e023867c8f58e63131d98b7d5c9e;p=nb.git

text mode
---

diff --git a/lib/perl/NB/CGI.pm b/lib/perl/NB/CGI.pm
index fa92b9d4..28dc6807 100644
--- a/lib/perl/NB/CGI.pm
+++ b/lib/perl/NB/CGI.pm
@@ -3,26 +3,25 @@
 #
 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;
@@ -32,90 +31,14 @@ sub new {
 	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 '&nbsp;'} @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 = (
@@ -204,89 +127,96 @@ sub header_status {
 		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 {
@@ -294,29 +224,161 @@ sub header {
 	# 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 '&nbsp;'} @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;