Skip to content
Permalink
3.3
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
######################################################################
#
# EPrints::Repository
#
######################################################################
#
#
######################################################################
=pod
=for Pod2Wiki
=head1 NAME
B<EPrints::Repository> - Single connection to a specific EPrints Repository
=head1 DESCRIPTION
This module is really a Repository, REALLY. The name is up to date
and everything :-)
EPrints::Repository represents a connection to the EPrints system. It
connects to a single EPrints repository, and the database used by
that repository.
Each Repository has a "current language". If you are running in a
multilingual mode, this is used by the HTML rendering functions to
choose what language to return text in.
The Repository object also knows about the current apache connection,
if there is one, including the CGI parameters.
If the connection requires a username and password then it can also
give access to the L<EPrints::DataObj::User> object representing the user who is
causing this request. See current_user().
The Repository object also provides access to the L<EPrints::XHTML> class which contains
many methods for creating XHTML results which can be returned via the web
interface.
=head1 METHODS
=cut
######################################################################
#
# INSTANCE VARIABLES:
#
# $self->{database}
# A EPrints::Database object representing the connection
# to the database.
#
# $self->{noise}
# The "noise" level which this connection should run at. Zero
# will produce only error messages. Higher numbers will produce
# more warnings and commentary.
#
# $self->{request}
# A mod_perl object representing the request to apache, if any.
#
# $self->{query}
# A CGI.pm object also representing the request, if any.
#
# $self->{offline}
# True if this is a command-line script.
#
# $self->{page}
# Used to store the output XHTML page between "build_page" and
# "send_page"
#
# $self->{lang}
# The current language that this session should use. eg. "en" or "fr"
# It is used to determine which phrases and template will be used.
#
######################################################################
package EPrints::Repository;
use EPrints;
use EPrints::Const qw( :trigger );
#use URI::Escape;
use CGI qw(-compile);
use strict;
######################################################################
=pod
=item $repository = EPrints::Repository->new( %opts )
Creates and returns a new repository object. This is a utility object only and
will only have the basic system configuration available.
=item $repository = EPrints::Repository->new( $repository_id, %opts )
Create a connection to an EPrints repository $repository_id which provides
access to the database and to the repository configuration.
Options:
db_connect - 1
check_db - 1
noise - 0
=cut
######################################################################
# opts:
# consume_post (default 1), assumes cgi=1
# cgi (default 0)
# noise (default 0)
# db_connect (default 1)
# check_db (default 1)
#
sub new
{
my $class = shift;
if( @_ % 2 == 0 )
{
return $class->_new( @_ );
}
my( $repository_id, %opts ) = @_;
EPrints::Utils::process_parameters( \%opts, {
consume_post => 1,
cgi => 0,
noise => 0,
db_connect => 1,
check_db => 1,
});
my $self = bless {}, $class;
$self->{noise} = $opts{noise};
$self->{noise} = 0 if ( !defined $self->{noise} );
$self->{used_phrases} = {};
$self->{offline} = 1;
if( $opts{cgi} )
{
EPrints->abort( __PACKAGE__."::new() called with cgi argument" );
}
$self->{id} = $repository_id;
$self->load_config();
if( $self->{noise} >= 2 ) { print "\nStarting EPrints Repository.\n"; }
if( $self->{offline} )
{
# Set a script to use the default language unless it
# overrides it
$self->change_lang(
$self->get_conf( "defaultlanguage" ) );
}
else
{
# running as CGI, Lets work out what language the
# client wants...
$self->change_lang( get_session_language(
$self,
$self->{request} ) );
}
if( defined $opts{db_connect} && $opts{db_connect} == 0 )
{
$opts{check_db} = 0;
}
else
{
# Create a database connection
if( $self->{noise} >= 2 ) { print "Connecting to DB ... "; }
$self->{database} = EPrints::Database->new( $self );
if( !defined $self->{database} )
{
# Database connection failure - noooo!
$self->render_error( $self->html_phrase(
"lib/session:fail_db_connect" ) );
#$self->get_repository->log( "Failed to connect to database." );
return undef;
}
}
#cjg make this a method of EPrints::Database?
if( !defined $opts{check_db} || $opts{check_db} )
{
# Check there are some tables.
# Well, check for the most important table, which
# if it's not there is a show stopper.
unless( $self->{database}->is_latest_version )
{
my $cur_version = $self->{database}->get_version || "unknown";
if( $self->{database}->has_table( "eprint" ) )
{
EPrints::abort(
"Database tables are in old configuration (version $cur_version). Please run:\nepadmin upgrade ".$self->get_repository->get_id );
}
else
{
EPrints::abort(
"No tables in the MySQL database! ".
"Did you run create_tables?" );
}
$self->{database}->disconnect();
return undef;
}
}
if( $self->{noise} >= 2 ) { print "done.\n"; }
if( !$self->{offline} && (!defined $opts{consume_post} || $opts{consume_post}) )
{
$self->read_params;
}
$self->call( "session_init", $self, $self->{offline} );
$self->{loadtime} = time();
return( $self );
}
sub _new
{
my( $class, %opts ) = @_;
my $self = bless {}, $class;
$self->{offline} = 1;
$self->{config} = EPrints::Config::system_config();
$self->{config}->{field_defaults} = {}
if !defined $self->{config}->{field_defaults};
$self->{config}->{defaultlanguage} = 'en';
$self->{config}->{languages} = [qw( en )];
$self->_load_datasets or EPrints->abort( "Failed to load datasets" );
$self->_load_languages or EPrints->abort( "Failed to load languages" );
$self->_load_storage or EPrints->abort( "Failed to load storage" );
$self->_load_plugins or EPrints->abort( "Failed to load plugins" );
$self->change_lang( $self->config( "defaultlanguage" ) );
$self->{loadtime} = time();
return $self;
}
=begin InternalDoc
=item $repo->init_from_thread()
Do whatever needs to be done to reinstate the repository after a new thread is spawned.
This is called during the CLONE() stage.
=end InternalDoc
=cut
sub init_from_thread
{
my( $self ) = @_;
# force recreation of XML object
delete $self->{xml};
# force reload
# $self->{loadtime} = 0;
$self->_load_workflows();
$self->_load_languages();
$self->_load_templates();
$self->_load_citation_specs();
$self->_load_storage();
}
# add the relative paths + http_* config if not set already by cfg.d
sub _add_live_http_paths
{
my( $self ) = @_;
my $config = $self->{config};
$config->{"rel_path"} = $self->get_url(
path => "static",
);
$config->{"rel_cgipath"} = $self->get_url(
path => "cgi",
);
}
######################################################################
=pod
=begin InternalDoc
=item $request = $repository->request;
Return the Apache request object (from mod_perl) or undefined if
this isn't a CGI script.
=end InternalDoc
=cut
######################################################################
sub get_request { &request }
sub request
{
my( $self ) = @_;
return $self->{request};
}
######################################################################
=pod
=over 4
=item $query = $repository->query
Return the L<CGI> object describing the current HTTP query, or
undefined if this isn't a CGI script.
=cut
######################################################################
sub get_query { &query }
sub query
{
my( $self ) = @_;
return undef if $self->{offline};
if( !defined $self->{query} )
{
$self->read_params;
}
return $self->{query};
}
######################################################################
=pod
=item $value or @values = $repository->param( $name )
Passes through to CGI.pm param method.
$value = $repository->param( $name ): returns the value of CGI parameter
$name.
$value = $repository->param( $name ): returns the value of CGI parameter
$name.
@values = $repository->param: returns an array of the names of all the
CGI parameters in the current request.
=cut
######################################################################
sub param
{
my( $self, $name ) = @_;
if( !defined $self->{query} )
{
$self->read_params;
}
if( !wantarray )
{
my $value = ( $self->{query}->param( $name ) );
if( EPrints::Utils::is_set( $value ) )
{
utf8::decode($value) if EPrints::Utils::is_set( $value );
}
return $value;
}
# Called in an array context
my @result;
if( defined $name )
{
if( $self->{query}->can('multi_param') ) ##Github #391 System running older version of CGI do not have multi_param. Check before calling. #Code by Patrick McSweeney
{
@result = $self->{query}->multi_param( $name );
}
else
{
@result = $self->{query}->param( $name );
}
}
else
{
@result = $self->{query}->param;
}
for( @result )
{
next if( !EPrints::Utils::is_set( $_ ) );
utf8::decode($_);
}
return( @result );
}
######################################################################
=pod
=begin InternalDoc
=item $repository->remote_ip
A wrapper method which - when available - returns the true IP of the
client. This will not return the IP of any Proxy/load balancer in-between.
=end InternalDoc
=cut
######################################################################
sub remote_ip
{
my( $self ) = @_;
# need an HTTP request...
return if $self->{offline};
my $r = $self->get_request;
return if !$r;
# Proxy has set the "X-Forwarded-For" HTTP header?
my $ip = $r->headers_in->{"X-Forwarded-For"};
# Sanitise and clean up $ip from XFF, if any.
if( EPrints::Utils::is_set( $ip ) )
{
# sanitise: remove lead commas and all whitespace
$ip =~ s/^\s*,+|\s+//g;
# slice: take only first address from the list
$ip =~ s/,.*//;
}
# Apache v2.4+ (http://httpd.apache.org/docs/trunk/developer/new_api_2_4.html)
if( !EPrints::Utils::is_set( $ip ) && $r->can( "useragent_ip" ) )
{
$ip = $r->useragent_ip;
}
# Apache v2.0-2.2
if( !EPrints::Utils::is_set( $ip ) && $r->connection->can( "client_ip" ) )
{
$ip = $r->connection->client_ip;
}
if( !EPrints::Utils::is_set( $ip ) && $r->connection->can( "remote_ip" ) )
{
$ip = $r->connection->remote_ip;
}
return $ip;
}
######################################################################
=pod
=begin InternalDoc
=item $repository->terminate
Perform any cleaning up necessary, for example SQL cache tables which
are no longer needed.
=end InternalDoc
=cut
######################################################################
sub terminate
{
my( $self ) = @_;
$self->call( "session_close", $self );
if( $self->{noise} >= 2 ) { print "Ending EPrints Repository.\n\n"; }
# if we're online then clean-up happens later
return if !$self->{offline};
$self->{database}->disconnect();
# give garbage collection a hand.
foreach( keys %{$self} ) { delete $self->{$_}; }
}
sub load_config
{
my( $self, $load_xml ) = @_;
$load_xml = 1 if !defined $load_xml;
$self->{config} = EPrints::Config::load_repository_config_module( $self->{id} );
# add defaults
if( !defined $self->{config}->{variables_path} )
{
$self->{config}->{variables_path} = $self->config( 'archiveroot' )."/var";
}
unless( defined $self->{config} )
{
print STDERR "Could not load repository config perl files for $self->{id}\n";
return;
}
$self->{class} = "EPrints::Config::".$self->{id};
$self->_add_http_paths;
# re-add live paths
$self->_add_live_http_paths;
# If loading any of the XML config files then
# abort loading the config for this repository.
if( $load_xml )
{
# $self->generate_dtd() || return;
$self->_load_workflows() || return;
$self->_load_namedsets() || return;
$self->_load_datasets() || return;
$self->_load_languages() || return;
$self->_load_templates() || return;
$self->_load_citation_specs() || return;
$self->_load_storage() || return;
}
$self->_load_plugins() || return;
$self->{field_defaults} = {};
return $self;
}
######################################################################
=pod
=item $xml = $repo->xml
Return an L<EPrints::XML> object for working with XML.
=cut
######################################################################
sub xml($)
{
my( $self ) = @_;
return $self->{xml} if defined $self->{xml};
return $self->{xml} = EPrints::XML->new( $self );
}
######################################################################
=pod
=item $xhtml = $repo->xhtml
Return an L<EPrints::XHTML> object for working with XHTML.
=cut
######################################################################
sub xhtml($)
{
my( $self ) = @_;
return $self->{xhtml} if defined $self->{xhtml};
return $self->{xhtml} = EPrints::XHTML->new( $self );
}
######################################################################
=pod
=item $eprint = $repository->eprint( $eprint_id );
A convience method to return the L<EPrints::DataObj::EPrint> with
the given ID, or undef.
Equivent to $repository->dataset("eprint")->dataobj( $eprint_id )
=cut
######################################################################
sub eprint($$)
{
my( $repository, $eprint_id ) = @_;
return $repository->dataset( "eprint" )->get_object( $repository, $eprint_id );
}
######################################################################
=pod
=item $user = $repository->current_user
Return the current logged in L<EPrints::DataObj::User> for this session.
Return undef if there isn't one.
=cut
######################################################################
sub current_user
{
my( $self ) = @_;
if( $self->{offline} )
{
return undef;
}
if( $self->{logged_out} )
{
return undef;
}
if( !defined $self->{current_user} )
{
return undef if( $self->{already_in_current_user} );
$self->{already_in_current_user} = 1;
# custom auth
if( $self->get_repository->can_call( 'get_current_user' ) )
{
$self->{current_user} = $self->get_repository->call( 'get_current_user', $self );
}
# cookie auth
if( !defined $self->{current_user} )
{
$self->{current_user} = $self->_current_user_auth_cookie;
}
# basic auth
if( !defined $self->{current_user} )
{
$self->{current_user} = $self->_current_user_auth_basic;
}
$self->{already_in_current_user} = 0;
}
return $self->{current_user};
}
######################################################################
=pod
=item $user = $repository->user( $user_id );
A convience method to return the L<EPrints::DataObj::User> with
the given ID, or undef.
Equivent to $repository->dataset("user")->dataobj( $user_id )
=cut
######################################################################
sub user($$)
{
my( $repository, $user_id ) = @_;
return $repository->dataset( "user" )->get_object( $repository, $user_id );
}
######################################################################
=pod
=item $user = $repository->user_by_username( $username );
Return the user with the given username, or undef.
=cut
######################################################################
sub user_by_username($$)
{
my( $repository, $username ) = @_;
return EPrints::DataObj::User::user_with_username( $repository, $username )
}
######################################################################
=pod
=item $user = $repository->user_by_email( $email );
Return the L<EPrints::DataObj::User> with the given email, or undef.
=cut
######################################################################
sub user_by_email($$)
{
my( $repository, $email ) = @_;
return EPrints::DataObj::User::user_with_email( $repository, $email )
}
sub _add_http_paths
{
my( $self ) = @_;
my $config = $self->{config};
if( $config->{securehost} )
{
$config->{secureport} ||= 443;
}
# Backwards-compatibility: http is fairly simple, https may go wrong
if( !defined($config->{"http_root"}) )
{
my $u = URI->new( $config->{"base_url"} );
$config->{"http_root"} = $u->path;
$u = URI->new( $config->{"perl_url"} );
$config->{"http_cgiroot"} = $u->path;
}
$config->{"http_cgiroot"} ||= $config->{"http_root"}."/cgi";
if( $config->{"securehost"} )
{
$config->{"https_root"} = $config->{"securepath"}
if !defined($config->{"https_root"});
$config->{"https_root"} = $config->{"http_root"}
if !defined($config->{"https_root"});
$config->{"https_cgiroot"} = $config->{"http_cgiroot"}
if !defined($config->{"https_cgiroot"});
}
$config->{"http_url"} ||= $self->get_url(
scheme => ($config->{host} ? "http" : "https"),
host => 1,
path => "static",
);
$config->{"http_cgiurl"} ||= $self->get_url(
scheme => ($config->{host} ? "http" : "https"),
host => 1,
path => "cgi",
);
$config->{"https_url"} ||= $self->get_url(
scheme => "https",
host => 1,
path => "static",
);
$config->{"https_cgiurl"} ||= $self->get_url(
scheme => "https",
host => 1,
path => "cgi",
);
# old-style configuration names
$config->{"urlpath"} ||= $config->{"http_root"};
$config->{"base_url"} ||= $config->{"http_url"} . "/";
$config->{"perl_url"} ||= $config->{"http_cgiurl"};
$config->{"frontpage"} ||= $config->{"http_url"} . "/";
$config->{"userhome"} ||= $config->{"http_cgiroot"} . "/users/home";
}
######################################################################
=pod
=begin InternalDoc
=item $success = $repository_config->_load_workflows
Attempts to load and cache the workflows for this repository
=end InternalDoc
=cut
######################################################################
sub _load_workflows
{
my( $self ) = @_;
$self->{workflows} = {};
# load system-level workflows
EPrints::Workflow::load_all(
$self->config( "lib_path" )."/workflows",
$self->{workflows} );
if( -e $self->config( "base_path" )."/site_lib/workflows" )
{
# load /site_lib/ workflows
EPrints::Workflow::load_all(
$self->config( "base_path" )."/site_lib/workflows",
$self->{workflows} );
}
if( -e $self->config( "config_path" )."/workflows" )
{
# load repository-specific workflows (may overwrite)
EPrints::Workflow::load_all(
$self->config( "config_path" )."/workflows",
$self->{workflows} );
}
return 1;
}
=begin InternalDoc
=item $repo->_load_storage()
Loads the storage layer which includes a XML workflow for storing items.
=end InternalDoc
=cut
sub _load_storage
{
my( $self ) = @_;
$self->{storage} = EPrints::Storage->new( $self );
return defined $self->{storage};
}
######################################################################
#
# $workflow_xml = $repository->get_workflow_config( $datasetid, $workflowid )
#
# Return the XML of the requested workflow
#
######################################################################
sub get_workflow_config
{
my( $self, $datasetid, $workflowid ) = @_;
my $r = EPrints::Workflow::get_workflow_config(
$workflowid,
$self->{workflows}->{$datasetid} );
return $r;
}
######################################################################
#
# $success = $repository_config->_load_languages
#
# Attempts to load and cache all the phrase files for this repository.
#
######################################################################
sub _load_languages
{
my( $self ) = @_;
my $defaultid = $self->config( "defaultlanguage" );
$self->{langs}->{$defaultid} = EPrints::Language->new(
$defaultid,
$self );
if( !defined $self->{langs}->{$defaultid} )
{
return 0;
}
my $langid;
foreach $langid ( @{$self->config( "languages" )} )
{
next if( $langid eq $defaultid );
$self->{langs}->{$langid} =
EPrints::Language->new(
$langid ,
$self ,
$self->{langs}->{$defaultid} );
if( !defined $self->{langs}->{$langid} )
{
return 0;
}
}
return 1;
}
######################################################################
=pod
=begin InternalDoc
=item $language = $repository->get_language( [$langid] )
Returns the EPrints::Language for the requested language id (or the
default for this repository if $langid is not specified).
=end InternalDoc
=cut
######################################################################
sub get_language
{
my( $self , $langid ) = @_;
if( !defined $langid )
{
$langid = $self->config( "defaultlanguage" );
}
return $self->{langs}->{$langid};
}
######################################################################
#
# $success = $repository_config->_load_citation_specs
#
# Attempts to load and cache all the citation styles for this repository.
#
######################################################################
sub _load_citation_specs
{
my( $self ) = @_;
$self->{citations} = {};
# load repository-specific citations
$self->_load_citation_dir( $self->config( "config_path" )."/citations" );
# load system-level citations (won't overwrite)
$self->_load_citation_dir( $self->config( "lib_path" )."/citations" );
if( -e $self->config( "base_path" )."/site_lib/citations" )
{
$self->_load_citation_dir( $self->config( "base_path" )."/site_lib/citations" );
}
return 1;
}
sub _load_citation_dir
{
my( $self, $dir ) = @_;
return unless -e $dir;
my $dh;
opendir( $dh, $dir );
my @dirs = ();
while( my $fn = readdir( $dh ) )
{
next if $fn =~ m/^\./;
push @dirs,$fn if( -d "$dir/$fn" );
}
closedir $dh;
# for each dataset dir
foreach my $dsid ( @dirs )
{
next if !exists $self->{datasets}->{$dsid};
opendir( $dh, "$dir/$dsid" );
while( my $fn = readdir( $dh ) )
{
next if $fn =~ m/^\./;
my $fileid = substr($fn,0,-4);
# prefer .xsl to .xml
next if $fn =~ /\.xml$/
&& $EPrints::XSLT &&
-e "$dir/$dsid/$fileid.xsl";
$self->_load_citation_file(
"$dir/$dsid/$fn",
$dsid,
$fileid
);
}
closedir $dh;
}
return 1;
}
sub _load_citation_file
{
my( $self, $file, $dsid, $fileid ) = @_;
return if defined $self->{citations}->{$dsid}->{$fileid};
if( !-e $file )
{
if( $fileid eq "default" )
{
EPrints::abort( "Default citation file for '$dsid' does not exist. Was expecting a file at '$file'." );
}
$self->log( "Citation file '$fileid' for '$dsid' does not exist. Was expecting a file at '$file'." );
return;
}
if( $file =~ /\.xml$/ )
{
$self->{citations}->{$dsid}->{$fileid} = EPrints::Citation::EPC->new(
$file,
dataset => $self->dataset( $dsid )
);
}
if( $file =~ /\.xsl$/ && $EPrints::XSLT )
{
$self->{citations}->{$dsid}->{$fileid} = EPrints::Citation::XSL->new(
$file,
dataset => $self->dataset( $dsid )
);
}
}
######################################################################
#
# $success = $repository_config->_load_templates
#
# Loads and caches all the html template files for this repository.
#
######################################################################
sub _load_templates
{
my( $self ) = @_;
$self->{html_templates} = {};
$self->{text_templates} = {};
$self->{template_mtime} = {};
$self->{template_path} = {};
foreach my $langid ( @{$self->config( "languages" )} )
{
foreach my $dir ($self->template_dirs( $langid ))
{
opendir( my $dh, $dir ) or next;
while( my $fn = readdir( $dh ) )
{
next if $fn =~ m/^\./;
next if $fn !~ /\.xml$/;
my $id = $fn;
$id =~ s/\.xml$//;
next if
exists $self->{template_mtime}->{$id} &&
exists $self->{template_mtime}->{$id}->{$langid};
$self->{template_path}->{$id}->{$langid} = "$dir/$fn";
$self->freshen_template( $langid, $id );
}
closedir( $dh );
}
if( !defined $self->{html_templates}->{default}->{$langid} )
{
EPrints::abort( "Failed to load default template for language $langid" );
}
}
return 1;
}
sub freshen_template
{
my( $self, $langid, $id ) = @_;
my $curr_lang = $self->{lang};
$self->change_lang( $langid );
my $path = $self->{template_path}->{$id}->{$langid};
my @filestat = stat( $path );
my $mtime = $filestat[9];
my $old_mtime = $self->{template_mtime}->{$id}->{$langid};
if( defined $old_mtime && $old_mtime == $mtime )
{
$self->{lang} = $curr_lang;
return;
}
my $template = $self->_load_template( $path );
if( !defined $template )
{
$self->{lang} = $curr_lang;
return 0;
}
$self->{html_templates}->{$id}->{$langid} = $template;
$self->{text_templates}->{$id}->{$langid} = $self->_template_to_text( $template, $langid );
$self->{template_mtime}->{$id}->{$langid} = $mtime;
}
sub _template_to_text
{
my( $self, $template, $langid ) = @_;
$template = $self->xml->clone( $template );
my $divide = "61fbfe1a470b4799264feccbbeb7a5ef";
my @pins = $template->getElementsByTagName("pin");
foreach my $pin ( @pins )
{
#$template
my $parent = $pin->getParentNode;
my $textonly = $pin->getAttribute( "textonly" );
my $ref = "pin:".$pin->getAttribute( "ref" );
if( defined $textonly && $textonly eq "yes" )
{
$ref.=":textonly";
}
my $textnode = $self->xml->create_text_node( $divide.$ref.$divide );
$parent->replaceChild( $textnode, $pin );
}
my @prints = $template->getElementsByTagName("print");
foreach my $print ( @prints )
{
my $parent = $print->getParentNode;
my $ref = "print:".$print->getAttribute( "expr" );
my $textnode = $self->xml->create_text_node( $divide.$ref.$divide );
$parent->replaceChild( $textnode, $print );
}
my @phrases = $template->getElementsByTagName("phrase");
foreach my $phrase ( @phrases )
{
my $done_phrase = EPrints::XML::EPC::process( $phrase, session=>$self );
my $parent = $phrase->getParentNode;
$parent->replaceChild( $done_phrase, $phrase );
}
$self->_divide_attributes( $template, $divide );
my @r = split( "$divide", $self->xhtml->to_xhtml( $template ) );
return \@r;
}
sub _divide_attributes
{
my( $self, $node, $divide ) = @_;
return unless( $self->xml->is( $node, "Element" ) );
foreach my $kid ( $node->childNodes )
{
$self->_divide_attributes( $kid, $divide );
}
my $attrs = $node->attributes;
return unless defined $attrs;
for( my $i = 0; $i < $attrs->length; ++$i )
{
my $attr = $attrs->item( $i );
my $v = $attr->nodeValue;
next unless( $v =~ m/\{/ );
my $name = $attr->nodeName;
my @r = EPrints::XML::EPC::split_script_attribute( $v, $name );
my @r2 = ();
for( my $i = 0; $i<scalar @r; ++$i )
{
if( $i % 2 == 0 )
{
push @r2, $r[$i];
}
else
{
push @r2, "print:".$r[$i];
}
}
if( scalar @r % 2 == 0 )
{
push @r2, "";
}
my $newv = join( $divide, @r2 );
$attr->setValue( $newv );
}
return;
}
sub _load_template
{
my( $self, $file ) = @_;
my $doc = $self->parse_xml( $file );
if( !defined $doc ) { return undef; }
my $html = ($doc->getElementsByTagName( "html" ))[0];
my $rvalue;
if( !defined $html )
{
print STDERR "Missing <html> tag in $file\n";
}
else
{
$rvalue = $self->xml->clone( $html );
}
$self->xml->dispose( $doc );
return $rvalue;
}
######################################################################
=pod
=begin InternalDoc
=item $template = $repository->get_template_parts( $langid, [$template_id] )
Returns an array of utf-8 strings alternating between XML and the id
of a pin to replace. This is used for the faster template construction.
=end InternalDoc
=cut
######################################################################
sub get_template_parts
{
my( $self, $langid, $tempid ) = @_;
if( !defined $tempid ) { $tempid = 'default'; }
$self->freshen_template( $langid, $tempid );
my $t = $self->{text_templates}->{$tempid}->{$langid};
if( !defined $t )
{
EPrints::abort( <<END );
Error. Template not loaded.
Language: $langid
Template ID: $tempid
END
}
return $t;
}
######################################################################
=pod
=begin InternalDoc
=item $template = $repository->get_template( $langid, [$template_id] )
Returns the DOM document which is the webpage template for the given
language. Do not modify the template without cloning it first.
=end InternalDoc
=cut
######################################################################
sub get_template
{
my( $self, $langid, $tempid ) = @_;
if( !defined $tempid ) { $tempid = 'default'; }
$self->freshen_template( $langid, $tempid );
my $t = $self->{html_templates}->{$tempid}->{$langid};
if( !defined $t )
{
EPrints::abort( <<END );
Error. Template not loaded.
Language: $langid
Template ID: $tempid
END
}
return $t;
}
######################################################################
#
# $success = $repository_config->_load_namedsets
#
# Loads and caches all the named set lists from the cfg/namedsets/ directory.
#
######################################################################
sub _load_namedsets
{
my( $self ) = @_;
my @paths = (
$self->config( "base_path" )."/site_lib/namedsets",
$self->config( "config_path" )."/namedsets",
);
# load /namedsets/*
foreach my $dir ( @paths )
{
next if !-e $dir;
my $dh;
opendir( $dh, $dir );
my @type_files = ();
while( my $fn = readdir( $dh ) )
{
next if $fn=~m/^\./;
push @type_files, $fn;
}
closedir( $dh );
foreach my $tfile ( @type_files )
{
my $file = $dir."/".$tfile;
my $type_set = $tfile;
open( FILE, $file ) || EPrints::abort( "Could not read $file" );
my @types = ();
foreach my $line (<FILE>)
{
$line =~ s/\015?\012?$//s;
$line =~ s/#.*$//;
$line =~ s/^\s+//;
$line =~ s/\s+$//;
my @values = split(' ',$line);
$line = $values[0];
next if (!defined $line);
push @types, $line;
}
close FILE;
$self->{types}->{$type_set} = \@types;
}
}
return 1;
}
######################################################################
=pod
=begin InternalDoc
=item @type_ids = $repository->get_types( $type_set )
Return an array of keys for the named set. Comes from
/cfg/types/foo.xml
=end InternalDoc
=cut
######################################################################
sub get_types
{
my( $self, $type_set ) = @_;
if( !defined $self->{types}->{$type_set} )
{
$self->log( "Request for unknown named set: $type_set" );
return ();
}
return @{$self->{types}->{$type_set}};
}
######################################################################
#
# $success = $repository_config->_load_datasets
#
# Loads and caches all the EPrints::DataSet objects belonging to this
# repository.
#
######################################################################
sub _load_datasets
{
my( $self ) = @_;
$self->{datasets} = {};
# system datasets
my %info = %{EPrints::DataSet::get_system_dataset_info()};
# repository-specific datasets
my $repository_datasets = $self->config( "datasets" );
foreach my $ds_id ( keys %{$repository_datasets||{}} )
{
my $dataset = $repository_datasets->{$ds_id};
foreach my $key (keys %$dataset)
{
if( defined $dataset->{$key} )
{
$info{$ds_id}->{$key} = $dataset->{$key};
}
else
{
delete $info{$ds_id};
}
}
}
# sort the datasets so that derived datasets follow (and hence share
# their fields)
foreach my $ds_id (
sort { defined $info{$a}->{confid} <=> defined $info{$b}->{confid} }
keys %info
)
{
$self->{datasets}->{$ds_id} = EPrints::DataSet->new(
repository => $self,
name => $ds_id,
%{$info{$ds_id}}
);
}
return 1;
}
######################################################################
=pod
=begin InternalDoc
=item @dataset_ids = $repository->get_dataset_ids()
Returns a list of dataset ids in this repository.
=end InternalDoc
=cut
######################################################################
sub get_dataset_ids
{
my( $self ) = @_;
return keys %{$self->{datasets}};
}
######################################################################
=pod
=begin InternalDoc
=item @dataset_ids = $repository->get_sql_dataset_ids()
Returns a list of dataset ids that have database tables.
=end InternalDoc
=cut
######################################################################
sub get_sql_dataset_ids
{
my( $self ) = @_;
my @dataset_ids = $self->get_dataset_ids();
return grep { !$self->get_dataset( $_ )->is_virtual } @dataset_ids;
}
######################################################################
=pod
=begin InternalDoc
=item @counter_ids = $repository->get_sql_counter_ids()
Returns a list of counter ids generated by the database.
=end InternalDoc
=cut
######################################################################
sub get_sql_counter_ids
{
my( $self ) = @_;
my @counter_ids;
foreach my $ds_id ($self->get_sql_dataset_ids)
{
my $dataset = $self->get_dataset( $ds_id );
foreach my $field ($dataset->get_fields)
{
next unless $field->isa( "EPrints::MetaField::Counter" );
my $c_id = $field->get_property( "sql_counter" );
push @counter_ids, $c_id if defined $c_id;
}
}
return @counter_ids;
}
######################################################################
=pod
=item $dataset = $repository->dataset( $setname )
Return a given L<EPrints::DataSet> or undef if it doesn't exist.
=cut
######################################################################
sub get_dataset { return dataset( @_ ); }
sub dataset($$;$)
{
my( $self, $setname, $quiet ) = @_;
my $ds = $self->{datasets}->{$setname};
if( !defined $ds && !$quiet )
{
$self->log( "Unknown dataset: ".$setname );
}
return $ds;
}
######################################################################
#
# $success = $repository_config->_load_plugins
#
# Load any plugins distinct to this repository.
#
######################################################################
sub _load_plugins
{
my( $self ) = @_;
# if we're reloading we need to reset the system plugins
if( defined $self->{plugins} )
{
$self->{plugins}->reset;
}
$self->{plugins} = EPrints::PluginFactory->new( $self );
return defined $self->{plugins};
}
=begin InternalDoc
=item $plugins = $repository->get_plugin_factory()
Return the plugins factory object.
=end InternalDoc
=cut
sub get_plugin_factory
{
my( $self ) = @_;
return $self->{plugins};
}
######################################################################
#
# $classname = $repository->get_plugin_class
#
# Returns the perl module for a plugin with this id, using global
# and repository-sepcific plugins.
#
######################################################################
sub get_plugin_class
{
my( $self, $pluginid ) = @_;
return $self->{plugins}->get_plugin_class( $pluginid );
}
######################################################################
=pod
=item $confitem = $repository->config( $key, [@subkeys] )
Returns a named configuration setting including those defined in archvies/<archive_id>/cfg/cfg.d/
$repository->config( "stuff", "en", "foo" )
is equivalent to
$repository->config( "stuff" )->{en}->{foo}
=cut
######################################################################
sub get_conf { return config( @_ ); }
sub config($$@)
{
my( $self, $key, @subkeys ) = @_;
my $val = $self->{config}->{$key};
foreach( @subkeys )
{
return undef unless defined $val;
$val = $val->{$_};
}
return $val;
}
=begin InternalDoc
=item $repository->run_trigger( TRIGGER_ID, %params )
Run all the triggers with the given TRIGGER_ID. Any return values are
set in the properties passed in in %params
=end InternalDoc
=cut
sub run_trigger
{
my( $self, $type, %params ) = @_;
my $fs = $self->config( "triggers", $type );
return if !defined $fs;
$params{repository} = $self;
my $rc;
TRIGGER: foreach my $priority ( sort { $a <=> $b } keys %{$fs} )
{
foreach my $f ( @{$fs->{$priority}} )
{
$rc = &{$f}( %params );
last TRIGGER if defined $rc && $rc eq EP_TRIGGER_DONE;
}
}
return $rc;
}
######################################################################
=pod
=item $repository->log( $msg )
Calls the log method from ArchiveConfig.pm for this repository with the
given parameters. Basically logs the comments wherever the site admin
wants them to go. Printed to STDERR by default.
=cut
######################################################################
sub log
{
my( $self , $msg) = @_;
if( $self->config( 'show_ids_in_log' ) )
{
my @m2 = ();
foreach my $line ( split( '\n', $msg ) )
{
push @m2,"[".$self->{id}."] ".$line;
}
$msg = join("\n",@m2);
}
if( $self->can_call( 'log' ) )
{
$self->call( 'log', $self, $msg );
}
else
{
print STDERR "$msg\n";
}
}
######################################################################
=pod
=item $result = $repository->call( $cmd, @params )
Calls the subroutine named $cmd from the configuration perl modules
for this repository with the given params and returns the result.
=cut
######################################################################
sub call
{
my( $self, $cmd, @params ) = @_;
my $fn;
if( ref $cmd eq "ARRAY" )
{
$fn = $self->config( @$cmd );
$cmd = join( "->",@{$cmd} );
}
else
{
$fn = $self->config( $cmd );
}
if( !defined $fn || ref $fn ne "CODE" )
{
# Can't log, as that could cause a loop.
Carp::carp( "Undefined or invalid function: $cmd\n" );
return;
}
my( $r, @r );
if( wantarray )
{
@r = eval { return &$fn( @params ) };
}
else
{
$r = eval { return &$fn( @params ) };
}
if( $@ )
{
print "$@\n";
exit 1;
}
return wantarray ? @r : $r;
}
######################################################################
=pod
=item $boolean = $repository->can_call( @cmd_conf_path )
Return true if the given subroutine exists in this repository's config
package.
=cut
######################################################################
sub can_call
{
my( $self, @cmd_conf_path ) = @_;
my $fn = $self->config( @cmd_conf_path );
return( 0 ) unless( defined $fn );
return( 0 ) unless( ref $fn eq "CODE" );
return 1;
}
######################################################################
=pod
=item $result = $repository->try_call( $cmd, @params )
Calls the subroutine named $cmd from the configuration perl modules
for this repository with the given params and returns the result.
If the subroutine does not exist then quietly returns undef.
This is used to call deprecated callback subroutines.
=cut
######################################################################
sub try_call
{
my( $self, $cmd, @params ) = @_;
return unless $self->can_call( $cmd );
return $self->call( $cmd, @params );
}
######################################################################
=pod
=begin InternalDoc
=item @dirs = $repository->get_store_dirs
Returns a list of directories available for storing documents. These
may well be symlinks to other hard drives.
=end InternalDoc
=cut
######################################################################
sub get_store_dirs
{
my( $self ) = @_;
my $docroot = $self->config( "documents_path" );
opendir( my $dh, $docroot )
or EPrints->abort( "Error opening document directory $docroot: $!" );
my( @dirs, $dir );
foreach my $dir (sort readdir( $dh ))
{
next if( $dir =~ m/^\./ );
next unless( -d $docroot."/".$dir );
push @dirs, $dir;
}
closedir( $dh );
if( !@dirs )
{
EPrints->system->mkdir( "$docroot/disk0" )
or EPrints->abort( "No storage directories found in $docroot" );
push @dirs, "disk0";
}
return @dirs;
}
sub get_store_dir
{
my( $self ) = @_;
my @dirs = $self->get_store_dirs;
# df not available, just return last dir found
return $dirs[$#dirs] if $self->config( "disable_df" );
my $root = $self->config( "documents_path" );
my $warnsize = $self->config( "diskspace_warn_threshold" );
my $errorsize = $self->config( "diskspace_error_threshold" );
my $warn = 1;
my $error = 1;
my %space;
foreach my $dir (@dirs)
{
my $space = EPrints::Platform::free_space( "$root/$dir" );
$space{$dir} = $space;
if( $space > $errorsize )
{
$error = 0;
}
if( $space > $warnsize )
{
$warn = 0;
}
}
@dirs = sort { $space{$a} <=> $space{$b} } @dirs;
# Check that we do have a place for the new directory
if( $error )
{
# Argh! Running low on disk space overall.
$self->log(<<END);
*** URGENT ERROR
*** Out of disk space.
*** All available drives have under $errorsize kilobytes remaining.
*** No new eprints may be added until this is rectified.
END
$self->mail_administrator( "lib/eprint:diskout_sub", "lib/eprint:diskout" );
}
# Warn the administrator if we're low on space
elsif( $warn )
{
$self->log(<<END);
Running low on diskspace.
All available drives have under $warnsize kilobytes remaining.
END
$self->mail_administrator( "lib/eprint:disklow_sub", "lib/eprint:disklow" );
}
# return the store with the most space available
return $dirs[$#dirs];
}
=item @dirs = $repository->template_dirs( $langid )
Returns a list of directories from which template files may be sourced, where the first matching template encountered is used.
The directories searched are:
archives/[archiveid]/cfg/lang/[langid]/templates/
archives/[archiveid]/cfg/templates/
archives/[archiveid]/cfg/themes/[themeid]/lang/[langid]/templates/
archives/[archiveid]/cfg/themes/[themeid]/templates/
lib/themes/[themeid]/templates/
lib/lang/[langid]/templates/
lib/templates/
=cut
sub template_dirs
{
my( $self, $langid ) = @_;
my @dirs;
my $config_path = $self->config( "config_path" );
my $lib_path = $self->config( "lib_path" );
# themes path: /archives/[repoid]/cfg/lang/[langid]templates/
push @dirs, "$config_path/lang/$langid/templates";
# repository path: /archives/[repoid]/cfg/templates/
push @dirs, "$config_path/templates";
my $theme = $self->config( "theme" );
if( defined $theme )
{
# themes path: /archives/[repoid]/cfg/themes/lang/[langid]templates/
push @dirs, "$config_path/themes/$theme/lang/$langid/templates";
# themes path: /archives/[repoid]/cfg/themes/lang/[langid]templates/
push @dirs, "$config_path/themes/$theme/templates";
push @dirs, "$lib_path/themes/$theme/templates";
}
# system path: /lib/templates/
push @dirs, "$lib_path/lang/$langid/templates";
push @dirs, "$lib_path/templates";
return @dirs;
}
######################################################################
=pod
=begin InternalDoc
=item @dirs = $repository->get_static_dirs( $langid )
Returns a list of directories from which static files may be sourced.
Directories are returned in order of importance, most important first.
=end InternalDoc
=cut
######################################################################
sub get_static_dirs
{
my( $self, $langid ) = @_;
my @dirs;
my $config_path = $self->config( "config_path" );
my $lib_path = $self->config( "lib_path" );
my $site_lib_path = $self->config( "base_path" )."/site_lib";
# repository path: /archives/[repoid]/cfg/static/
push @dirs, "$config_path/lang/$langid/static";
push @dirs, "$config_path/static";
# themes path: /archives/[repoid]/cfg/themes/
my $theme = $self->config( "theme" );
if( defined $theme )
{
push @dirs, "$config_path/themes/$theme/static";
push @dirs, "$lib_path/themes/$theme/static";
}
# site_lib
push @dirs, "$site_lib_path/lang/$langid/static";
push @dirs, "$site_lib_path/static";
# system path: /lib/static/
push @dirs, "$lib_path/lang/$langid/static";
push @dirs, "$lib_path/static";
return @dirs;
}
######################################################################
=pod
=begin InternalDoc
=item $size = $repository->get_store_dir_size( $dir )
Returns the current storage (in bytes) used by a given documents dir.
$dir should be one of the values returned by $repository->get_store_dirs.
This should not be called if disable_df is set in SystemSettings.
=end InternalDoc
=cut
######################################################################
sub get_store_dir_size
{
my( $self , $dir ) = @_;
my $filepath = $self->config( "documents_path" )."/".$dir;
if( ! -d $filepath )
{
return undef;
}
return EPrints::Platform::free_space( $filepath );
}
######################################################################
=pod
=begin InternalDoc
=item $domdocument = $repository->parse_xml( $file, $no_expand );
Turns the given $file into a XML DOM document. If $no_expand
is true then load &entities; but do not expand them to the values in
the DTD.
This function also sets the path in which the Parser will look for
DTD files to the repository's config directory.
Returns undef if an error occurs during parsing.
=end InternalDoc
=cut
######################################################################
sub parse_xml
{
my( $self, $file, $no_expand ) = @_;
my $lib_path = $self->config( "lib_path" ) . "/";
my $doc = eval { $self->xml->parse_file( $file,
base_path => $lib_path,
no_expand => $no_expand ) };
if( !defined $doc )
{
$self->log( "Failed to parse XML file: $file: $@ ($lib_path)" );
}
return $doc;
}
######################################################################
=pod
=item $id = $repository->id
Returns the id string of this repository.
=cut
######################################################################
*get_id = \&id;
sub id
{
my( $self ) = @_;
return $self->{id};
}
######################################################################
=pod
=item $returncode = $repository->exec( $cmd_id, %map )
Executes a system command. $cmd_id is the id of the command as
set in SystemSettings and %map contains a list of things to "fill in
the blanks" in the invocation line in SystemSettings.
=cut
######################################################################
sub exec
{
my( $self, $cmd_id, %map ) = @_;
return EPrints::Platform::exec( $self, $cmd_id, %map );
}
=begin InternalDoc
=item $returncode = $repository->read_exec( $fh, $cmd_id, %map )
Executes a system command and captures the output, see L</exec>.
=end InternalDoc
=cut
sub read_exec
{
my( $self, $fh, $cmd_id, %map ) = @_;
return EPrints::Platform::read_exec( $self, $fh, $cmd_id, %map );
}
sub can_execute
{
my( $self, $cmd_id ) = @_;
my $cmd = $self->config( "executables", $cmd_id );
return ($cmd and $cmd ne "NOTFOUND") ? 1 : 0;
}
sub can_invoke
{
my( $self, $cmd_id, %map ) = @_;
my $execs = $self->config( "executables" );
foreach( keys %{$execs} )
{
$map{$_} = $execs->{$_} unless $execs->{$_} eq "NOTFOUND";
}
my $command = $self->config( "invocation" )->{ $cmd_id };
return 0 if( !defined $command );
$command =~ s/\$\(([a-z]*)\)/quotemeta($map{$1})/gei;
return 0 if( $command =~ /\$\([a-z]*\)/i );
return 1;
}
######################################################################
=pod
=begin InternalDoc
=item $commandstring = $repository->invocation( $cmd_id, %map )
Finds the invocation for the specified command from SystemSetting and
fills in the blanks using %map. Returns a string which may be executed
as a system call.
All arguments are ESCAPED using quotemeta() before being used (i.e. don't
pre-escape arguments in %map).
=end InternalDoc
=cut
######################################################################
sub invocation
{
my( $self, $cmd_id, %map ) = @_;
my $execs = $self->config( "executables" );
my $command = $self->config( "invocation" )->{ $cmd_id };
# platform-specific quoting
$command =~ s/\$\(([a-z0-9_]+)\)/
exists($map{$1}) ?
EPrints->system->quotemeta($map{$1}) :
EPrints->system->quotemeta($execs->{$1})
/gei;
return $command;
}
######################################################################
=pod
=begin InternalDoc
=item $defaults = $repository->get_field_defaults( $fieldtype )
Return the cached default properties for this metadata field type.
or undef.
=end InternalDoc
=cut
######################################################################
sub get_field_defaults
{
my( $self, $fieldtype ) = @_;
return $self->{field_defaults}->{$fieldtype};
}
######################################################################
=pod
=begin InternalDoc
=item $repository->set_field_defaults( $fieldtype, $defaults )
Cache the default properties for this metadata field type.
=end InternalDoc
=cut
######################################################################
sub set_field_defaults
{
my( $self, $fieldtype, $defaults ) = @_;
$self->{field_defaults}->{$fieldtype} = $defaults;
}
######################################################################
=pod
=item ( $returncode, $output) = $repository->test_config
This runs "epadmin test" as an external script to test if the current
configuraion on disk loads OK. This can be used by the web interface
to test if changes to config. files may be saved, or not.
$returncode will be zero if everything seems OK.
If not, then $output will contain the output of epadmin test
=cut
######################################################################
sub test_config
{
my( $self ) = @_;
my $rc = 0;
my $output = "";
my $tmp = File::Temp->new;
$rc = EPrints::Platform::read_perl_script( $self, $tmp, "-e",
'use EPrints qw( no_check_user ); my $ep = EPrints->new(); my $repo = $ep->repository( "'.$self->{id}.'" ); '
);
while(<$tmp>)
{
$output .= $_;
}
return ($rc/256, $output);
}
=item $ok = $repository->reload_config
Trigger a configuration reload on the next request/index.
To reload the configuration right now just call L</load_config>.
=cut
sub reload_config
{
my( $self ) = @_;
my $file = $self->config( "variables_path" )."/last_changed.timestamp";
if( open(my $fh, ">", $file) )
{
print $fh "This file last poked at: ".EPrints::Time::human_time()."\n";
close $fh;
}
else
{
$self->log( "Error writing to $file: $!" );
return 0;
}
return 1;
}
######################################################################
=pod
=begin InternalDoc
=item $langid = EPrints::Repository::get_session_language( $repository, $request )
Given an repository object and a Apache (mod_perl) request object, this
method decides what language the session should be.
First it looks at the HTTP cookie "eprints_lang", failing that it
looks at the preferred language of the request from the HTTP header,
failing that it looks at the default language for the repository.
The language ID it returns is the highest on the list that the given
eprint repository actually supports.
=end InternalDoc
=cut
######################################################################
sub get_session_language
{
my( $repository, $request ) = @_; #$r should not really be passed???
my @prefs;
# IMPORTANT! This function must not consume
# The post request, if any.
my $cookie = EPrints::Apache::AnApache::cookie(
$request,
"eprints_lang" );
push @prefs, $cookie if defined $cookie;
# then look at the accept language header
my $accept_language = EPrints::Apache::AnApache::header_in(
$request,
"Accept-Language" );
if( defined $accept_language )
{
# Middle choice is exact browser setting
foreach my $browser_lang ( split( /, */, $accept_language ) )
{
$browser_lang =~ s/;.*$//;
push @prefs, $browser_lang;
}
}
# last choice is always...
push @prefs, $repository->get_conf( "defaultlanguage" );
# So, which one to use....
my $arc_langs = $repository->get_conf( "languages" );
foreach my $pref_lang ( @prefs )
{
foreach my $langid ( @{$arc_langs} )
{
if( $pref_lang eq $langid )
{
# it's a real language id, go with it!
return $pref_lang;
}
}
}
print STDERR <<END;
Something odd happened in the language selection code...
Did you make a default language which is not in the list of languages?
END
return undef;
}
######################################################################
=pod
=begin InternalDoc
=item $repository->change_lang( $newlangid )
Change the current language of the session. $newlangid should be a
valid country code for the current repository.
An invalid code will cause eprints to terminate with an error.
=end InternalDoc
=cut
######################################################################
sub change_lang
{
my( $self, $newlangid ) = @_;
if( !defined $newlangid )
{
$newlangid = $self->get_conf( "defaultlanguage" );
}
$self->{lang} = $self->get_language( $newlangid );
if( !defined $self->{lang} )
{
die "Unknown language: $newlangid, can't go on!";
# cjg (maybe should try english first...?)
}
}
######################################################################
=pod
=begin InternalDoc
=item $xhtml_phrase = $repository->html_phrase( $phraseid, %inserts )
Return an XHTML DOM object describing a phrase from the phrase files.
$phraseid is the id of the phrase to return. If the same ID appears
in both the repository-specific phrases file and the system phrases file
then the repository-specific one is used.
If the phrase contains <ep:pin> elements, then each one should have
an entry in %inserts where the key is the "ref" of the pin and the
value is an XHTML DOM object describing what the pin should be
replaced with.
=end InternalDoc
=cut
######################################################################
sub html_phrase
{
my( $self, $phraseid , %inserts ) = @_;
# $phraseid [ASCII]
# %inserts [HASH: ASCII->DOM]
#
# returns [DOM]
$self->{used_phrases}->{$phraseid} = 1;
my $r = $self->{lang}->phrase( $phraseid , \%inserts , $self );
#my $s = $self->make_element( "span", title=>$phraseid );
#$s->appendChild( $r );
#return $s;
return $r;
}
######################################################################
=pod
=begin InternalDoc
=item $utf8_text = $repository->phrase( $phraseid, %inserts )
Performs the same function as html_phrase, but returns plain text.
All HTML elements will be removed, <br> and <p> will be converted
into breaks in the text. <img> tags will be replaced with their
"alt" values.
=end InternalDoc
=cut
######################################################################
sub phrase
{
my( $self, $phraseid, %inserts ) = @_;
$self->{used_phrases}->{$phraseid} = 1;
foreach( keys %inserts )
{
$inserts{$_} = $self->make_text( $inserts{$_} );
}
my $r = $self->{lang}->phrase( $phraseid, \%inserts , $self);
my $string = EPrints::Utils::tree_to_utf8( $r, 40 );
EPrints::XML::dispose( $r );
return $string;
}
######################################################################
=pod
=begin InternalDoc
=item $language = $repository->get_lang
Return the EPrints::Language object for this sessions current
language.
=end InternalDoc
=cut
######################################################################
sub get_lang
{
my( $self ) = @_;
return $self->{lang};
}
######################################################################
=pod
=begin InternalDoc
=item $langid = $repository->get_langid
Return the ID code of the current language of this session.
=end InternalDoc
=cut
######################################################################
sub get_langid
{
my( $self ) = @_;
return $self->{lang}->get_id();
}
#cjg: should be a util? or even a property of repository?
######################################################################
=pod
=begin InternalDoc
=item $value = EPrints::Repository::best_language( $repository, $lang, %values )
$repository is the current repository. $lang is the preferred language.
%values contains keys which are language ids, and values which is
text or phrases in those languages, all translations of the same
thing.
This function returns one of the values from %values based on the
following logic:
If possible, return the value for $lang.
Otherwise, if possible return the value for the default language of
this repository.
Otherwise, if possible return the value for "en" (English).
Otherwise just return any one value.
This means that the view sees the best possible phrase.
=end InternalDoc
=cut
######################################################################
sub best_language
{
my( $repository, $lang, %values ) = @_;
# no options?
return undef if( scalar keys %values == 0 );
# The language of the current session is best
return $values{$lang} if( defined $lang && defined $values{$lang} );
# The default language of the repository is second best
my $defaultlangid = $repository->get_conf( "defaultlanguage" );
return $values{$defaultlangid} if( defined $values{$defaultlangid} );
# Bit of personal bias: We'll try English before we just
# pick the first of the heap.
return $values{en} if( defined $values{en} );
# Anything is better than nothing.
my $akey = (keys %values)[0];
return $values{$akey};
}
######################################################################
=pod
=begin InternalDoc
=item $viewname = $repository->get_view_name( $dataset, $viewid )
Return a UTF8 encoded string containing the human readable name
of the /view/ section with the ID $viewid.
=end InternalDoc
=cut
######################################################################
sub get_view_name
{
my( $self, $dataset, $viewid ) = @_;
return $self->phrase(
"viewname_".$dataset->confid()."_".$viewid );
}
######################################################################
=pod
=begin InternalDoc
=item $db = $repository->get_database
Return the current EPrints::Database connection object.
=end InternalDoc
=cut
######################################################################
sub get_db { return $_[0]->get_database; } # back compatibility
sub database { shift->get_database( @_ ) }
sub get_database
{
my( $self ) = @_;
return $self->{database};
}
=begin InternalDoc
=item $store = $repository->get_storage
Return the storage control object.
=end InternalDoc
=cut
sub get_storage
{
my( $self ) = @_;
return $self->{storage};
}
######################################################################
=pod
=begin InternalDoc
=item $repository = $repository->get_repository
Return the EPrints::Repository object associated with the Repository.
=end InternalDoc
=cut
######################################################################
sub get_archive { return $_[0]->get_repository; }
sub get_repository
{
my( $self ) = @_;
return $self;
}
######################################################################
=pod
=begin InternalDoc
=item $url = $repository->current_url( [ @OPTS ] [, $page] )
Utility method to get various URLs. See L<EPrints::URL>.
With no arguments returns the current full URL without any query part.
# Return the current static path
$repository->current_url( path => "static" );
# Return the current cgi path
$repository->current_url( path => "cgi" );
# Return a full URL to the current cgi path
$repository->current_url( host => 1, path => "cgi" );
# Return a full URL to the static path under HTTP
$repository->current_url( scheme => "http", host => 1, path => "static" );
# Return a full URL to the image 'foo.png'
$repository->current_url( host => 1, path => "images", "foo.png" );
=end InternalDoc
=cut
######################################################################
sub get_url { &current_url }
sub current_url
{
my( $self, @opts ) = @_;
my $url = EPrints::URL->new( session => $self );
return $url->get( @opts );
}
######################################################################
=pod
=begin InternalDoc
=item $uri = $repository->get_uri
Returns the URL of the current script. Or "undef".
=end InternalDoc
=cut
######################################################################
sub get_uri
{
my( $self ) = @_;
return undef unless defined $self->{request};
return( $self->{"request"}->uri );
}
######################################################################
=pod
=begin InternalDoc
=item $uri = $repository->get_full_url
Returns the URL of the current script plus the CGI params.
=end InternalDoc
=cut
######################################################################
sub get_full_url
{
my( $self ) = @_;
return undef unless defined $self->{request};
# we need to add parameters manually to avoid semi-colons
my $url = URI->new( $self->get_url( host => 1 ) );
$url->path( $self->{request}->uri );
my @params = $self->param;
my @form;
foreach my $param (@params)
{
push @form, map { $param => $_ } $self->param( $param );
}
utf8::encode($_) for @form; # utf-8 encoded URL
$url->query_form( @form );
return $url;
}
######################################################################
=pod
=begin InternalDoc
=item $noise_level = $repository->get_noise
Return the noise level for the current session. See the explanation
under EPrints::Repository->new()
=end InternalDoc
=cut
######################################################################
sub get_noise
{
my( $self ) = @_;
return( $self->{noise} );
}
######################################################################
=pod
=begin InternalDoc
=item $boolean = $repository->is_online
Return true if this script is running via CGI, return false if we're
on the command line.
=end InternalDoc
=cut
######################################################################
sub get_online { &is_online }
sub is_online
{
my( $self ) = @_;
return( !$self->{offline} );
}
######################################################################
=pod
=begin InternalDoc
=item $secure = $repository->is_secure
Returns true if we're using HTTPS/SSL (checks get_online first).
=end InternalDoc
=cut
######################################################################
sub get_secure { &is_secure }
sub is_secure
{
my( $self ) = @_;
# mod_ssl sets "HTTPS", but only AFTER the Auth stage
return $self->is_online &&
($ENV{"HTTPS"} || $self->get_request->dir_config( 'EPrints_Secure' ));
}
#############################################################
#############################################################
=pod
=begin InternalDoc
=back
=head2 DOM Related Methods
These methods help build XML. Usually, but not always XHTML.
=over 4
=end InternalDoc
=cut
#############################################################
#############################################################
######################################################################
=pod
=begin InternalDoc
=item $dom = $repository->make_element( $element_name, %attribs )
Return a DOM element with name ename and the specified attributes.
eg. $repository->make_element( "img", src => "/foo.gif", alt => "my pic" )
Will return the DOM object describing:
<img src="/foo.gif" alt="my pic" />
Note that in the call we use "=>" not "=".
=end InternalDoc
=cut
######################################################################
sub make_element
{
my( $self, $ename , @opts ) = @_;
return $self->xml->create_element( $ename, @opts );
}
######################################################################
=pod
=begin InternalDoc
=item $dom = $repository->make_indent( $width )
Return a DOM object describing a C.R. and then $width spaces. This
is used to make nice looking XML for things like the OAI interface.
=end InternalDoc
=cut
######################################################################
sub make_indent
{
my( $self, $width ) = @_;
return $self->xml->create_text_node( "\n"." "x$width );
}
######################################################################
=pod
=begin InternalDoc
=item $dom = $repository->make_comment( $text )
Return a DOM object describing a comment containing $text.
eg.
<!-- this is a comment -->
=end InternalDoc
=cut
######################################################################
sub make_comment
{
my( $self, $text ) = @_;
$self->xml->create_comment( $text );
}
# $text is a UTF8 String!
######################################################################
=pod
=begin InternalDoc
=item $DOM = $repository->make_text( $text )
Return a DOM object containing the given text. $text should be
UTF-8 encoded.
Characters will be treated as _text_ including < > etc.
eg.
$repository->make_text( "This is <b> an example" );
Would return a DOM object representing the XML:
"This is &lt;b&gt; an example"
=end InternalDoc
=cut
######################################################################
sub make_text
{
my( $self, $text ) = @_;
return $self->xml->create_document_fragment if !defined $text;
return $self->xml->create_text_node( $text );
}
######################################################################
=pod
=begin InternalDoc
=item $DOM = $repository->make_javascript( $code, %attribs )
Return a new DOM "script" element containing $code in javascript. %attribs will
be added to the script element, similar to make_element().
E.g.
<script type="text/javascript">
// <![CDATA[
alert("Hello, World!");
// ]]>
</script>
=end InternalDoc
=cut
######################################################################
sub make_javascript
{
my( $self, $text, %attr ) = @_;
my $script = $self->xml->create_element( "script", type => "text/javascript", %attr );
if( defined $text )
{
chomp($text);
$script->appendChild( $self->xml->create_text_node( "\n// " ) );
$script->appendChild( $self->xml->create_cdata_section( "\n$text\n// " ) );
}
else
{
$script->appendChild( $self->xml->create_comment( "padder" ) );
}
return $script;
}
######################################################################
=pod
=begin InternalDoc
=item $fragment = $repository->make_doc_fragment
Return a new XML document fragment. This is an item which can have
XML elements added to it, but does not actually get rendered itself.
If appended to an element then it disappears and its children join
the element at that point.
=end InternalDoc
=cut
######################################################################
sub make_doc_fragment
{
my( $self ) = @_;
return $self->xml->create_document_fragment;
}