package Context; ###### Context for servicing a request
#	$Id: Context.pm,v 1.19 2003/05/09 19:32:14 steve Exp $
#	This file is part of Combo and is licensed under the GPL and LGPL.
#	Copyright 2001-2002 by the authors.  See README and LICENSE files
#	for more details or see http://penguinsong.org/.

### Context provides the environment for servicing a request.

#	Context provides a complete environment for servicing a particular
#	request: it points to the site configuration (Site::Config), request
#	(CGI), user profile (Site::User), directory (Site::Resource), MIME
#	type (Type::*), and version control (Site::Version) objects.

#	In addition, Context provides the global name-value table for 
#	entity substitution, as performed by, e.g., AMP::Process.  In this
#	role, it serves as the top-level namespace in the process stack.

#	Usage:  my $path  = $ENV{PATH_INFO};	# the default
#		my $trans = $ENV{TRANS_PATH};
#		my $c = new Context($path, $trans);
#		my $q = $c->getCGI;

#	It is not necessary to pass $path if the path to the resource
#	really is PATH_INFO.  In some cases, however, it may be necessary
#	to modify the path (e.g. to expand "//" constructs) or to use a
#	different environment variable (e.g. REDIRECT_URL in dir-index).

# The environment variable PATH_INFO contains the URL path that follows the
# CGI's name, so that's the URL path to the file to be processed.  Normally
# PATH_TRANSLATED holds the corresponding file path, but if there's a // in 
# the path it's going to be wrong unless mod_rewrite has taken care of it.

# Normally mod_rewrite expands //'s before Apache looks them up, then
# unexpands them before the user sees them.  So we're ok unless the URL
# starting with /Ccgi/ was entered by hand.  That's a no-no, but eventually
# we'll have to worry about it.


## Note:  references:

#	Perl uses reference counts for storage allocation; this means that
#	it's important to avoid circular references, since these will cause
#	memory leaks if we're running under mod_perl.  In addition, most
#	classes in Site:: don't depend on the request, and so may be
#	persistent: it's important that they have no references back to the
#	Context.  They may, however, refer to one another.  In particular,
#	_anything_ can refer to Site::Config, which is both global and
#	constant.  Site::Version _does_ depend on the Context; it has
#	both user and path information in its state, but little else.

BEGIN {
    use Exporter();
    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $cvsid = '$Id: Context.pm,v 1.19 2003/05/09 19:32:14 steve Exp $ ';
    $cvsid =~ /,v ([0-9]+.[0-9]+)/;
    $VERSION=$1;
    @ISA = qw(Exporter);
    @EXPORT = ( );

}

use AMP::Tagset;
use Site::Config;
use Site::Util;
use Site::User;

##########################################################################
###
### Constructors:
###

### Context->new($path, $trans_path)
#	Obtain a new Context for the given path.
#	$path is the URL path from the request, usually from PATH_INFO
#	$trans_path is the translated path, usually from PATH_TRANSLATED
#	
sub new {
    my ($class, $path, $trans_path) = (@_);

    my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) 
	= localtime(time);
    
    # force leading zero's on 2-byte fields

    $sec	= sprintf("%02d", $sec);
    $min	= sprintf("%02d", $min);
    $hour	= sprintf("%02d", $hour);
    $mday	= sprintf("%02d", $mday);
    $mon	= sprintf("%02d", $mon + 1);		# mon has range 0..11
    $yday	= sprintf("%03d", $yday);
    my $yy	= sprintf("%02d", $year % 100);
    
    $path = '/' unless $path;

    my $config	     = Site::Config->new($ENV{'SERVER_NAME'});
    my $parent_path  = parentPath("$path");
    my $basename     = Site::Util::baseName("$path");
    my $trimmed_path = "$parent_path/$basename";
    my $real_path    = $config->makeRealPath("$path");

    $trans_path = ($trans_path)
	? $config->makeRealPath("$trans_path")
	: $config->translatePath($real_path);

    my $mgr = $config->getTypeManager;
    
    # Initialize instance variables and entities
    my $self = { '_Config'=> $config,
		 '_CGI'   => new CGI,
		 '_type_manager' => $mgr,

		 # parent path, basename
		 'parent.path'   => $parent_path,
		 'page.filename' => Site::Util::fileName("$path"),
		 'page.basename' => $basename,
		 
		 # Path and path-related entities
		 'path'		   => $path,	# === legacy
		 'page.path'	   => $path,
		 'page.real.path'  => $real_path,
		 'page.path.links' => linkifyPath($trimmed_path),
		 '_page.file'	   => $trans_path,

		 # per-directory entities:  snagged in initialize

		 # Date-related entities
		 'time.ss'	=> $sec,
		 'time.mm'	=> $min,
		 'time.hh'	=> $hour,
		 'date.dd'	=> $mday,
		 'date.mm'	=> $mon,
		 'date.yyyy'	=> $year+1900, # year is actualYear-1900
		 'date.yy'	=> $yy,
		 'date.yday'	=> $yday,

	     };

    $self = bless $self, $class;
    $self-> initialize($path);
    return $self;
}

##########################################################################
###
### Access Functions:
###

### $c->get(name, [default]) -> value
#	get a value.  Typically these are also useable as entities, but names
#	starting with non-alpha-numeric characters will not be recognized as
#	entities and so can be used internally with impunity.
#
#	Anything not found in the Context will be searched for in the
#	site configuration.
#
sub get {
    my ($self, $n, $def) = @_;
    my $v = $self->{$n};
    $v = $self->getConfig->get($n) unless defined $v;
    if (!defined $v) {
	my $u = $self->getUser();
	$v = $u->get($n) if $u;
    }
    return (defined $v)? $v : $def;
}

### $c->qget($param, $name, $default)
#	Return $param from the query if defined.
#	Otherwise, return $c->get($name, $default)
#
sub qget {
    my ($self, $p, $n, $def) = @_;
    my $q = $self->getCGI;
    my $v = (ref $q)? $q->param($p) : undef;
    return (defined $v)? $v : $self->get($n, $def);
}

sub param {
    my ($self, $p) = @_;
    my $q = $self->getCGI;
    return (ref $q)? $q->param($p) : undef;
}

### $c->getEntityNames() -> (name, ...)
#	Return the list of entity names defined in the context.
#	Names beginning with "_" are omitted because they're not 
#	legitimate entity names; these include both non-public 
#	information and non-HTML objects (e.g. _Config and _Version).
#
sub getEntityNames {
    my ($self) = @_;
    my @keys = ();
    foreach $k (keys(%$self)) {
	push(@keys, $k) unless $k =~ /^[._]/;
    }
    my $cfg = $self->getConfig;
    foreach $k (keys(%$cfg)) {
	push(@keys, $k) unless $k =~ /^[._]/ || defined $self->{$k} ;
    }
    return @keys;
}

### $c->getConfig()
#	Return the Site::Config instance.
sub getConfig {
    my ($self) = @_;
    return $self->{'_Config'};
}

### $c->getCGI()
#	Return the CGI instance
sub getCGI {
    my ($self) = @_;
    return $self->{'_CGI'};
}

### $c->getVersion()
#	Return the Site::Version (version control) instance.
sub getVersion {
    my ($self) = @_;
    return $self->{'_Version'};
}

### $c->getUser()
#	Return the Site::User (user profile) instance that applies to this
#	request. 
sub getUser {
    my ($self) = @_;
    return $self->{'_User'};
}

### $c->getResource()
#	Return the Site::Resource instance that applies to this request.
#	The Resource is used to operate on files in the directory indicated
#	by $path.
sub getResource {
    my ($self) = @_;
    return $self->{'_Resource'};
}


##########################################################################
###
### Indirect Access Functions:
###	These could all be done using $self->get, but we can save a step
###	because we already know that they're in the Config.
###



### $c->getSiteDir
sub getSiteDir {
    my $self = shift;
    return $self->getConfig->getSiteDir;
}

### $c->getDocRoot
sub getDocRoot {
    my $self = shift;
    return $self->getConfig->getDocRoot;
}

### $c->getServerName
sub getServerName {
    my $self = shift;
    return $self->getConfig->getServerName;
}

### $c->getTemplateDir
#	Return the directory that contains tag templates
sub getTemplateDir {
    my $self = shift;
    return $self->getConfig->getTemplateDir;
}

### $c->getBaseURL
#	Return a URL that points to the server base
sub getBaseURL {
    my $self = shift;
    return $self->getConfig->getBaseURL;
}


### === The following are more complex and somewhat dubious.
#   === they probably need to go somewhere else

### $c->getType($path)
sub getType {
    my ($self, $path) = @_;
    my $mgr = $self->{'_type_manager'};
    $path = $self->getRealPath unless $path;
    my $type = $mgr->getType($self, $path);
    $self->{'type.handler'} = ref $type;
    return $type;
}

### $c->getTagset
sub getTagset {
    my $self = shift;
    # === needs to be cached in $self, obviously ===
    if (!$tagset) { 
	$tagset = AMP::Tagset->new($self, $self->getTemplateDir); 
    }
    return $tagset;
}

### $c->getAreaMap
sub getAreaMap {
    my $self = shift;

    my @urls = split(" ", $self->get("area.urls"));
    my @text = split(" ", $self->get("area.text"));

    my $hash = {};
    for (my $i = @text; --$i >= 0; ) { 
	$hash->{$urls[$i]} = $text[$i]; 
    }
    return $hash;
}

# === these probably belong in Resource

### $c->getPath
sub getPath {
    my $self = shift;
    return $self->get('page.path');
}

### $c->getRealPath
sub getRealPath {
    my $self = shift;
    return $self->get('page.real.path');
}

sub getTransPath {
    my $self = shift;
    return $self->get('_page.file');
}

### $c->isDir
sub isDir {
    my $self = shift;
    return -d $root . $self->getRealPath;
}

### $c->getRealDirPath
sub getRealDirPath {
    my $self = shift;
    my $path = $self->get('page.real.path');
    my $root = $self->getDocRoot;
    return (-d "$root$path")? $path : parentPath($path);
}

### $c->getFileName
sub getFileName {
    my $self = shift;
    return $self->get('page.filename');
}

sub getTitle {
    my $self = shift;
    return $self->get('page.title');
}

sub setTitle {
    my ($self, $v) = @_;
    $self->{'page.title'} = $v;
}


##########################################################################
### 
### Initialization:
###


### $c->initialize($path)
#	Initialize a Context.   
#	Note that _CGI and _Config are already set at this point, as are
#	all of the date and page things.  Most of what we do here has to do
#	with loading the per-directory and per-user information.
#
sub initialize {
    my ($self, $path) = (@_);
    my $root = $self->getDocRoot;

    # set up areas

    # === set up Version, Resource, User

    # === go through directories starting at root; load config files
    # === probably belongs in Resource, actually.

    my $p = (-d "$root$path")? $path : parentPath($path); 
    my @p = split(/\//, $p);

    $p = $root;

    my $dirCF = $self->get("dir.cf", "..cf");

    # Look for and load per-directory config files, starting at docRoot
    # Note the "dir." prefix
    foreach $d (@p, ".") {
	next unless $d;
	# print STDERR "looking for $p/$dirCF\n";
	if (-f "$p/$dirCF") {
	    readConfig($self, "$p/$dirCF", "dir."); 
	    # print STDERR "loading $p/$dirCF\n";
	}
	$p .= "/$d";
    }

    # Obtain the User corresponding to this request:

    $self->{'_User'} = Site::User->fromContext($self);

    # Obtain theme information:

    my $theme = $self->get("dir.theme", "theme");

    # probably need to allow for themes in a subdirectory

    if ($theme !~ /^theme/) { $theme = "theme.$theme"; }
    if ($theme !~ /.cf$/) { $theme .= ".cf"; }

    $theme = $self->getSiteDir . '/' . $theme;
    $self->{'theme.file.path'} = $theme;

    $theme = $self->getDocRoot . $theme;
    readConfig($self, $theme, "theme.");
}

##########################################################################
### 
### Site-specific Utilities:
###

### $c->start_html($title) -> "<html>...<body...>"
#	Replacement for CGI::start_html, using current theme
#
sub start_html {
    my ($c, $title) = @_;
    my $q = $c->getCGI;
    # === actually need to build arg list in an array
    $q->start_html(-title   => $title,
		   -bgcolor => $c->get("theme.page.bg",    "#ffffff"),
		   -text    => $c->get("theme.page.text",  "#000000"),
		   -link    => $c->get("theme.page.link",  "#0000ff"),
		   -vlink   => $c->get("theme.page.vlink", "#0000cc"),
		   -alink   => $c->get("theme.page.alink", "#ff0000"),
		   );
}

### $c->printenv 
#	Print environment, entities, and other information for debugging
#
sub printenv {
    my $c = shift;

    print "<table width='100%' cellspacing='0'>\n";
    print "<tr><th align='left'><i>Debugging Information:</i></th>\n";
    print "    <td>&nbsp;</td></tr>\n";
    print "<tr><th><hr></th>\n";
    print "    <td><hr></td></tr>\n";
    print "<tr><th>Internal variables:</th>\n";
    print "    <td><hr></td></tr>\n";
    print "<tr><th align='right'><small>site directory</small>&nbsp;</th>"
	    . "<td><small>" . $c->getSiteDir . "</small></td></tr>\n";
    print "<tr><th align='right'><small>current working dir&nbsp;</small></th>"
	    . "<td><small>" . `pwd` . "</small></td></tr>\n";
    print "<tr><th align='right'><small>site config file&nbsp;</small></th>"
	    . "<td><small>" . $Site::Config::siteCF . "</small></td></tr>\n";
    print "<tr><th>Environment</th><td><hr></td></tr>\n";
    foreach my $e (sort keys(%ENV)) {
	my $v = $ENV{$e};
	if ($e eq 'HTTP_ACCEPT') { $v =~ s/\,/\, /g; }
	print "<tr><th align='right' valign='top'><small>$e</small>&nbsp;</th>"
	    . "<td><small>" . $v . "</small></td></tr>\n";
    }
    print "<tr><th>Entities</th><td><hr></td></tr>\n";
    foreach my $e (sort $c->getEntityNames) {
	print "<tr><th align='right'><small>$e</small>&nbsp;</th>"
	    . "<td><small>" . $c->get($e) . "</small></td></tr>\n";
    }
    print "</table>\n";
}


### Print directory for debugging
sub printdir {
    my ($c, $dir) = @_;

    my $root = $c->getDocRoot;
    my $realPath = $c->getRealPath;
    $dir = $c->getTransPath unless $dir;

    opendir(DIR, $dir);
    my @files = readdir(DIR);
    closedir DIR;

    print "<table>\n";
    foreach my $f (sort @files) {
	next if $f =~ /^\.|CVS|~$/&& $f ne '..';
	$f .= '/' if -d "$dir/$f";

	my $d = (-d "$dir/$f")? "?dir=1&amp;env=1&amp;debug=1" : "?env=1";
	my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, 
	    $atime, $mtime, $ctime, $blksiz, $blks) 
	    = stat "$dir/$f";
	print "<tr><td>$size</td>\n";
	print "    <td><a href='/Ccgi/file.cgi$realPath$f'>[raw]</a></td>\n";
	print "    <td><a href='/Ccgi/preview.cgi$realPath$f'>[pre]</a></td>\n";
	print "    <td><code><a href='$f$d'>$f</a></code></td></tr>\n";
    }
    print "</table>\n";
}


### $c->webPage($title, $text)
#	Put out a simple web page
sub webPage {
    my ($self, $title, $text) = @_;
    print "
<html>
  <head><title>$title</title>
  </head>
  <body>
  <h1>$title</h1>
  $text
  <hr>
  $ENV{'SERVER_SIGNATURE'}
  </body>
</html>
";
}

###########################################################################
'Package loaded';