view release on metacpan or  search on metacpan

lib/DiaColloDB/WWW/CGI.pm  view on Meta::CPAN

sub requestQuery { return $_[0]{request_query}; }
sub httpReferer { return $_[0]{http_referer}; }
sub httpHost { return $_[0]{http_host}; }
sub serverAddr { return $_[0]{server_addr}; }
sub serverPort {
  return $_[0]{server_port} if ($_[0]{server_port});
  my $host = $_[0]->httpHost;
  return $1 if ($host && $host =~ /:([0-9]+)$/);
  return $ENV{HTTPS} ? 443 : 80; ##-- guess port from scheme
}


## $uri    = $dbcgi->uri()
## $uri    = $dbcgi->uri($uri)
sub uri {
  return URI->new($_[1]) if (defined $_[1]);
  my $dbcgi = shift;
  my $host = $dbcgi->httpHost // '';
  my $port = $dbcgi->serverPort;
  my $scheme = ($ENV{HTTPS} ? 'https' : 'http');
  return URI->new(
		  #($host ? "http://$host" : "file://")
		  ($host ? "${scheme}://$host" : "file://") ##-- guess scheme from HTTPS environment variable
		  .( ($host && $host =~ /:[0-9]+$/) || $port==($scheme eq 'https' ? 443 : 80) ? '' : ":$port" )
		  .$dbcgi->requestUri
		 );
}

## $scheme = $dbcgi->uriScheme($uri?)
## $opaque = $dbcgi->uriOpaque($uri?)
## $path   = $dbcgi->uriPath($uri?)
## $frag   = $dbcgi->uriFragment($uri?)
## $canon  = $dbcgi->uriCanonical($uri?)
## $abs    = $dbcgi->uriAbs($uri?);
sub uriScheme { $_[0]->uri($_[1])->scheme; }
sub uriPath { $_[0]->uri($_[1])->path; }
sub uriFragment { $_[0]->uri($_[1])->fragment; }
sub uriCanonical { $_[0]->uri($_[1])->canonical->as_string; }
sub uriAbs { $_[0]->uri($_[1])->abs->as_string; }

## $dir = $dbcgi->uriDir($uri?)
##  + returns URI up to but not including query or fragment, truncating any trailing slashes
sub uriDir {
  my $uri = $_[0]->uri($_[1])->as_string;
  $uri =~ s{[?#].*$}{};
  $uri =~ s{/+[^/]*$}{};
  return $uri;
}

## $auth   = $dbcgi->uriAuthority($uri?)
## $pquery = $dbcgi->uriPathQuery($uri?)
## \@segs   = $dbcgi->uriPathSegments($uri?)
## $query  = $dbcgi->uriQuery($uri?)
## \%form  = $dbcgi->uriQueryForm($uri?)
## \@kws    = $dbcgi->uriQueryKeywords($uri?)
sub uriAuthority { $_[0]->uri($_[1])->authority; }
sub uriPathQuery { $_[0]->uri($_[1])->path_query; }
sub uriPathSegments { [$_[0]->uri($_[1])->path_segments]; }
sub uriQuery { $_[0]->uri($_[1])->query; }
sub uriQueryForm { {$_[0]->uri($_[1])->query_form}; }
sub uriQueryKeywords { [$_[0]->uri($_[1])->query_keywords]; }

## $userinfo = $dbcgi->uriUserInfo($uri?)
## $host     = $dbcgi->uriHost($uri?)
## $port     = $dbcgi->uriPort($uri?)
sub userinfo { $_[0]->uri($_[1])->userinfo; }
sub uriHost { $_[0]->uri($_[1])->host; }
sub uriPort { $_[0]->uri($_[1])->port; }

## $uristr = quri($base, \%form)
sub quri {
  shift if (isa($_[0],__PACKAGE__));
  my ($base,$form)=@_;
  my $uri=URI->new($base);
  $uri->query_form($uri->query_form, map {utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_} %{$form||{}});
  return $uri->as_string;
}

## $urisub = uuri($base, \%form)
## $uristr = $urisub->(\%form)
sub uuri {
  shift if (isa($_[0],__PACKAGE__));
  my $qbase = quri(@_);
  return sub { quri($qbase,@_); };
}

## $sqstring = sqstring($str)
sub sqstring {
  shift if (isa($_[0],__PACKAGE__));
  (my $s=shift) =~ s/([\\\'])/\\$1/g; "'$s'"
}

## $str = sprintf_(...)
sub sprintf_ {
  shift if (isa($_[0],__PACKAGE__));
  return CORE::sprintf($_[0],@_[1..$#_]);
}

## $mtime = $dbcgi->mtime($filename)
sub mtime {
  my $dbcgi = shift;
  my $file = shift;
  $file =~ s/^.*?=(\w+).*$/$1/ if ($file =~ /^dbi:/); ##-- trim dsns
  my @stat = stat($file);
  return $stat[9];
}

## $str = $dbcgi->timestamp()
##  + gets localtime timestamp
sub timestamp {
  #my $dbcgi = shift;
  return POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
}

## $json_str = PACKAGE->to_json($data)
## $json_str = PACKAGE::to_json($data)
## $json_str = PACKAGE->to_json($data,\%opts)
## $json_str = PACKAGE::to_json($data,\%opts)
sub to_json {
  shift if (isa($_[0],__PACKAGE__));
  return JSON::to_json($_[0]) if (@_==1);