#!/usr/local/bin/perl
BEGIN
{
# We must require DevUtils from a know location because we
# need it to set up our include path. The include path points
# to the work dir under the cannonical location so we pick up
# our ongoing development. We build a path by pulling e.g.
# pafrber off of ww2-idx-pfarber ( a symlink to ww2-idx)
# and concatenating /p/pfarber to the cannonical location.
# Therefore, in a browser, using the ww2-idx cgi, we
# get CVS committed behavior, while using ww2-idx-pfarber
# cgi in the URL gives us development behavior.
require $ENV{'DLXSROOT'} . '/lib/DevUtils.pm';
my ( $userpath ) = &GetDevUsernameFromScript;
unshift( @INC, $ENV{'DLXSROOT'} . '/lib' . $userpath );
}
# ----------------------------------------------------------------------
# global variables needed to configure for this specific wordwheel
require 'ww2-idx.cfg';
use strict;
# Lincoln Stein's CGI.pm ( restricted since it is quite large )
use CGI qw( :standard :html3 escape unescape escapeHTML );
# ---------- DLPS related ----------
use WW; # OO WW class definitions
use CollsInfo; # OO module to find DLPS-wide collection information
use DlpsSession; # OO module to manage user session
use DlpsUtils qw( :DEFAULT );
use TextClassUtils qw( :DEFAULT );
use TextClass;
# ---------- configuration globals ---------------
use vars qw(
%gPageParamToHtmlTpl $gHtmlDocRoot %gUserChoices
$gDefaultRealm %gWWModes $gCollDbName $gWWWindowRadius
$gTextClassCgi %gWWERRORS
);
# ---------------------------------------------------------------------
#
# Working CGI for the next-generation ( 2000 ) WordWheel mechanism
# using a pat50-indexed SGML file rather than a group of tab-delimited
# files that are grep-ed and employing cross-collection functionality
# ( multiple pat50 sesions ).
#
# ---------------------------------------------------------------------
#
# parameters passed in via the URL are:
#
# page=wwstart|wwfull
# [sid=5445kh32g54kjhg235k] -- session id if we are a child page
# [browse=wordwheel] -- only for statistics gathering
# c=a [c=b ...] -- initially requested collections
# [q1=word] -- wordwheel word
# [realm=r] -- wordwheel realm
# [top=n] [bottom=m] -- last wordwheel position
# [chartype=alpha|num|misc] -- wordwheel on number, alpha, stuff
#
# future work: view=detail|combined where we display a wordwheel
# which is the union over cross collections ( the current default ) or
# a detail where each collection is a separate column in the wordwheel
#
# ---------------------------------------------------------------------
## --------------------------------------------------------------------
## MAIN starts
## --------------------------------------------------------------------
# create the classic CGI object and as a side-effect get all URL parameters
my $gCgi = new CGI;
# remove all undef or empty URL parameters -- later code expects this
&DlpsUtils::CleanCgiParameters( $gCgi );
# set debug environment var so that all modules can access it
if ( $gCgi->param('debug') )
{
&DlpsUtils::SetupHtmlDebugging( $gCgi->param( 'debug' ) );
}
# ----------------------------------------------------------------------
# determine what is authorized and what is requested (hardcoded if we are
# not running under the web server
if ( ! exists $ENV{'AUTHZD_COLL'} || ( $ENV{'DEBUG'} && ( $ENV{'DEBUG'} eq 'auth' )))
{
# $ENV{'AUTHZD_COLL'} = ( 'yeats:voltaire:bosnia:gandf:ampo20' );
$ENV{'AUTHZD_COLL'} = ( 'voltaire' );
}
my @gAuthColls = &DlpsUtils::GetAuthListFromENV( );
# Does the URL have any colls that pass authorization? These become
# the requested colls.
my $gRequestedCollsRef = &_CollsSelect( $gCgi, \@gAuthColls );
# The session carries around this users' session data: start or
# inherit existing session based on URL sid=sd20fa5a0ddaf31bb e.g.
my $gDso = &DlpsUtils::StartSession( $gCgi );
# Update the session with this new requested colls and attach a
# collection info object with the new data to the session object
$gDso->UpdateSessionColls( $gCollDbName, \@gAuthColls, $gRequestedCollsRef );
# Bring in session's CollsInfo obj as global
my $gCio = $gDso->GetCollsInfoObject( );
# Wordwheel object for searching
my $gWWObj;
# Populate CollsInfo object with TextClass objects to support
# requested collections (now implicit in the TextClass object)
$gCio->AddTextClassObjects( );
# Intersect realms over requested collections
my ( $gRealmsInCommonRef, $gRealmsInCommonEngRef ) =
&_IntersectCollsRealms( $gCio, $gRequestedCollsRef );
# Page template name from URL page parameter
my $gPage = &_PageSelect( $gCgi );
# if debug is enabled as a URL parameter, dump info
&_Debug( $gDso, $gCio, $gCgi, \@gAuthColls, $gRequestedCollsRef );
if ( $gPage eq 'wwstart' )
{
&_HandleStartPage( $gCgi, $gDso, $gCio, $gRealmsInCommonRef, $gRealmsInCommonEngRef );
}
elsif ( $gPage eq 'wwfull' )
{
# User choice
my ( $choice, $mode ) = &_UserChoiceSelect( $gCgi );
if ( $choice eq 'simplesearch' )
{
# ----- Redirect to the TextClass Simple Search page -----
my $redirectURL = &_GetRedirectURL( $gCgi, $gRequestedCollsRef );
print( &CGI::redirect( $redirectURL ) );
}
else
{
# ----- Scroll existing or construct new wordwheel -----
# Character type
my $chartype = &_ChartypeSelect( $gCgi );
# q1
my $q1 = &_Q1Select( $gCgi, $chartype );
# Table size is always odd leaving room for a middle
# (possibly highlighted) middle row
my $tabsize = 2 * $gWWWindowRadius + 1;
# Does requested realm make sense vs. requested collections?
my $reqRealm = &_RealmSelect( $gCgi, $gCio, $gRequestedCollsRef );
# top, bottom
my ( $top, $bottom ) = &_SelectTopBottom( $gCgi );
#
# Instantiate and get results of WW search from WW object
#
eval
{
$gWWObj = new WW(
$gCio,
$reqRealm,
$chartype,
$q1,
$top,
$bottom,
$tabsize,
$mode,
);
};
if ( $@ )
{
&errorBail( $@ );
}
&_HandleFullPage( $gDso, $gCgi, $gCio,
$gRealmsInCommonRef, $gRealmsInCommonEngRef,
$chartype, $gWWObj );
}
}
else
{
&errorBail( $gWWERRORS{'NO_NO'} )
}
# This saves disk space when we commit the session during Close()
$gCio->RemoveTextClassObjects();
$gDso->Close;
exit;
## --------------------------------------------------------------------
## MAIN ends
## --------------------------------------------------------------------
# =====================================================================
#
# SUBROUTINES
#
# =====================================================================
# ----------------------------------------------------------------------
# NAME : Debug
# PURPOSE : when debug set, dump environment variables, URI variables,
# and collection information (from CollsInfo object)
# CALLED BY :
# CALLS :
# INPUT :
# RETURNS :
# NOTES :
# ----------------------------------------------------------------------
sub _Debug
{
my ( $dso, $cio, $cgi, $authCollsRef, $reqCollsRef ) = @_;
# ----------------------------------------------------------------------
# debugging requested?
if ( $ENV{'DEBUG'} && ( $ENV{'DEBUG'} eq 'all' || $ENV{'DEBUG'} eq 'ww' ) )
{
print( &CGI::p("Debugging $0"), &CGI::br(), &CGI::hr() );
print( &CGI::p(qq{Session ID is: }, $dso->GetSessionId(), &CGI::br(), &CGI::hr() ) );
print " Authorized Colls: " . (join ( " \n", @$authCollsRef ) );
print " Requested Colls: " . (join ( " \n", @$reqCollsRef ) );
print( &DlpsUtils::DumpEnvVars );
print( &CGI::br() . &CGI::hr() );
if ( defined( $cgi ) )
{
print( $cgi->dump() );
print( &CGI::br() . &CGI::hr() );
}
if ( defined( $cio ) )
{
print( $cio->HtmlDumpCollsInfo() );
print( &CGI::br() . &CGI::hr() );
}
}
}
# ----------------------------------------------------------------------
# NAME : ZeroOutGlobals
# PURPOSE : under mod_perl, all instances of this cgi run under
# one perl process. To avoid one stepping on the other,
# wipe out all globals
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : all globals
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _ZeroOutGlobals
{
}
# ----------------------------------------------------------------------
# NAME : _GetRedirectURL
# PURPOSE : build a URL to redirc to the simple search page
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _GetRedirectURL
{
my ( $cgi, $reqCollsRef ) = @_;
my $redirectCgi = new CGI( "" );
my @q1 = $cgi->param( 'q1' ) ? $cgi->param( 'q1' ) : 'a';
my $sid = $cgi->param( 'sid' );
my $realm2region = $cgi->param( 'realm' );
$redirectCgi->param( 'q1', @q1 );
$redirectCgi->param( 'sid', $sid );
$redirectCgi->param( 'rgn', $realm2region );
$redirectCgi->param( 'c', @$reqCollsRef );
$redirectCgi->param( 'view', 'reslist' );
$redirectCgi->param( 'type', 'simple' );
return ( $gTextClassCgi . "?" . $redirectCgi->query_string( ) );
}
# ----------------------------------------------------------------------
# NAME : StartSession
# PURPOSE : set the global $gSessionId and creates a DlpsSession object
# (which wraps an Apache::Session::DBI object)
# CALLED BY : main
# CALLS : DlpsSession->new
# INPUT :
# RETURNS :
# GLOBALS : $gCgi, sets $gSessionId, $gDso
# NOTES :
# ----------------------------------------------------------------------
sub _StartSession
{
my $cgi = shift;
# Get session id if there is one passed in
my $sessionId = $cgi->param( 'sid' );
my $dso;
eval
{
$dso = new DlpsSession( $sessionId );
};
if ( $@ )
{
&errorBail( $gWWERRORS{'NO_SESSION'} . $@ );
}
# If there was not a session id passed in, get the one created for
# the session object and add it to the cgi object as a URL
# parameter.
if ( ! $sessionId )
{
$cgi->param( 'sid', $dso->GetSessionId( ) );
}
return $dso;
}
# ----------------------------------------------------------------------
# NAME : RealmSelect
# PURPOSE :
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : gCgi
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _RealmSelect
{
my ( $cgi, $cio, $requestedCollsRef ) = @_;
my $realm = $cgi->param( 'realm' );
if ( ! $realm )
{
&errorBail( $gWWERRORS{'NO_REALM'} );
}
# realm must be valid for at least one collection or it defaults
# ('full text') but make sure default is a valid realm over this
# subset of collections
my $defaultRealmOk = 0;
foreach my $coll ( @$requestedCollsRef )
{
my @collRealms = $cio->GetCollKeyInfo( $coll, 'wwrealms' );
foreach my $r ( @collRealms )
{
if ( $realm eq $r )
{
return $realm;
}
}
# oops! would default work for this coll?
foreach my $r ( @collRealms )
{
if ( $gDefaultRealm eq $r )
{
$defaultRealmOk = 1;
}
}
}
if ( ! $defaultRealmOk )
{
&errorBail( $gWWERRORS{'NO_REALM'} );
}
return $gDefaultRealm;
}
# ----------------------------------------------------------------------
# NAME : _IntersectCollsRealms
# PURPOSE : determine what realms the requested colls have in
# commmon, i.e. lowest common denominator realms (LCD)
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : realms, realms in English
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES : Assumes 'full text' is always in common across all realms
# ----------------------------------------------------------------------
sub _IntersectCollsRealms
{
my ( $cio, $requestedCollsRef ) = @_;
my @collsRealmRefs;
# get list of realm sets
foreach my $coll ( @$requestedCollsRef )
{
my @collRealms = $cio->GetCollKeyInfo( $coll, 'wwrealms' );
# XXX skip author until bib serch is implemented
@collRealms = grep( !/author/, @collRealms );
push( @collsRealmRefs, \@collRealms );
}
# N-way intersect set of realm sets
my @nWayIntersection = &DlpsUtils::GetNWayIntersection( \@collsRealmRefs );
my @nWayIntersectionEng;
# Get the english name for each LCD realm
COMMONREALMNAME:
foreach my $commonRealm ( @nWayIntersection )
{
# find English name for LCD realm in some collection
foreach my $coll ( @$requestedCollsRef )
{
# get this collection's realms
my ( $i, @collRealms ) = ( 0, $cio->GetCollKeyInfo( $coll, 'wwrealms' ) );
for ( $i = 0; $i < scalar( @collRealms ); $i++ )
{
# if one of coll's realms is one of the LCD realms
# save it off
if ( $commonRealm eq $collRealms[$i] )
{
my @realmEnglish = $cio->GetCollKeyInfo( $coll, 'wwrealmsenglish' );
push( @nWayIntersectionEng, $realmEnglish[$i] );
next COMMONREALMNAME;
}
}
}
}
# Ensure we return at least full text
if ( ! @nWayIntersection )
{
$nWayIntersection[0] = 'full text';
$nWayIntersectionEng[0] = 'Full Text';
}
return ( \@nWayIntersection, \@nWayIntersectionEng );
}
# ----------------------------------------------------------------------
# NAME : PageSelect
# PURPOSE :
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : gCgi
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _PageSelect
{
my $cgi = shift;
my $pageName = $cgi->param ( 'page' );
if ( ! $gPageParamToHtmlTpl{$pageName} )
{
&errorBail( $gWWERRORS{'NO_PAGE'} );
}
return $pageName;
}
# ----------------------------------------------------------------------
# NAME : CollsSelect
# PURPOSE :
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : gCgi
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _CollsSelect
{
my ( $cgi, $authCollsRef ) = @_;
# intersect URL colls with authorized colls
my @requestedColls = &CollectionResolution( $cgi, $authCollsRef );
if ( scalar ( @requestedColls ) == 0 )
{
&errorBail( $gWWERRORS{'NO_COLLS'} );
}
return \@requestedColls;
}
# ----------------------------------------------------------------------
# NAME : ChartypeSelect
# PURPOSE :
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : gCgi
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _ChartypeSelect
{
my $cgi = shift;
return $gWWChartypes{'default'} if ( ! $cgi->param( 'chartype' ) );
return $cgi->param( 'chartype' );
}
# ----------------------------------------------------------------------
# NAME : _UserChoiceSelect
# PURPOSE : determine how the ww-full page should behave. either
# the user scrolled a wordwheel, submitted a list
# of checkboxes to a simple search or requested a new
# wordwheel. One choice, (search) comes in as a URL parameter
# from input submit, while the others are inferred by looking at the up,
# down button parameters, if present
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : user choice, scrolling mode
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _UserChoiceSelect
{
my $cgi = shift;
if ( $cgi->param( 'simplesearch' ) )
{
return ( $gUserChoices{'simplesearch'}, undef );
}
return ( $gUserChoices{'wordwheel'}, $gWWModes{'prev'} )
if ( $cgi->param( 'up.x' ) );
return ( $gUserChoices{'wordwheel'}, $gWWModes{'next'} )
if ( $cgi->param( 'down.x' ) );
return ( $gUserChoices{'wordwheel'}, $gWWModes{'new'} )
}
# ----------------------------------------------------------------------
# NAME : _Q1Select
# PURPOSE : parse the q1 URL parameter for a *new* wordwheel
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES : we are only interested in a single word so we split
# on any whitespace the user may have entered
# ----------------------------------------------------------------------
sub _Q1Select
{
my $cgi = shift;
if ( $cgi->param( 'q1' ) )
{
my $word;
$word = $cgi->param( 'q1' );
$word = lc( $word );
# NOTE: these patterns should agree with those in makeWordWheelFiles.pl
## Remove all non-alphanumeric at beginning
while ( $word =~ s/^[\&\!\"\#\$\%\(\)\*\+\,\.\/\:\;\<\=\>\?\@\[\\\]\^\`\{\|\}\~\s\'\-]+// )
{;}
## Remove all non-alphanumeric at end
while ( $word =~ s/[\&\!\"\#\$\%\(\)\*\+\,\.\/\:\;\<\=\>\?\@\[\\\]\^\`\{\|\}\~\s\'\-]+$// )
{;}
# Split on some embedded non-alphanumeric. Not '-' because
# e.g. of forty-two and not "'" because we treat "d'une" as a
# word but catch "mary,john" or hello(goodbye) e.g.
my @parts = split( /[\&\!\"\#\$\%\(\)\*\+\,\.\/\:\;\<\=\>\?\@\[\\\]\^\`\{\|\}\~\s]+/, $word);
# Just the first "word" entered, thank you very much.
return $parts[0];
}
my $chartype = shift;
return 'a' if ( $chartype eq 'alpha' );
# Numeric and non-alpha searches do not use a q1. Those searches
# return the complete chartype
return '';
}
# ----------------------------------------------------------------------
# NAME : _SelectTopBottom
# PURPOSE : support scrolling by setting the top,bottom item in the table
# based on a previous state. If top is undef, a wordwheel
# is being built for the first time
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _SelectTopBottom
{
my $cgi = shift;
my $top = $cgi->param( 'top' );
my $bottom = $cgi->param( 'bottom' );
return ( $top, $bottom );
}
# ----------------------------------------------------------------------
# NAME : _BuildWWRadioGroup
# PURPOSE :
# CALLED BY : PIO mechanism
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _BuildWWRadioGroup
{
my ( $realmsRef, $realmsEngRef, $piParamHashRef ) = @_;
my $name;
if ( exists( $$piParamHashRef{'name'} ) )
{
$name = $$piParamHashRef{'name'};
}
else
{
&errorBail( $gWWERRORS{'NO_PI'}, 'Radio Group lacks name.' );
}
my $columns;
if ( exists( $$piParamHashRef{'columns'} ) )
{
$columns = $$piParamHashRef{'columns'};
}
else
{
$columns = 5;
}
my %labelHash = &DlpsUtils::GetParallelHash( $realmsRef, $realmsEngRef );
my $radioGroup = &CGI::radio_group( -name => $name,
-labels => \%labelHash,
-values => $realmsRef,
-columns => $columns );
return $radioGroup;
}
# ----------------------------------------------------------------------
# NAME : _BuildWWQuickLink
# PURPOSE :
# CALLED BY : PIO mechanism
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _BuildWWQuickLink
{
my ( $cgi, $realmsRef, $realmsEngRef, $piParamHashRef ) = @_;
my $tempCgi = new CGI( "" );
$tempCgi->param( 'page', 'wwfull' );
my @colls = $cgi->param( 'c' );
$tempCgi->param( 'c', @colls );
my ( $quickLink, $i );
foreach my $realmEng ( @$realmsEngRef )
{
$tempCgi->param( 'realm', $$realmsRef[$i++] );
# alphabetic
my $anchors;
my $href;
$tempCgi->param( 'chartype', 'alpha' );
foreach my $letter ( 'A'..'Z' )
{
$tempCgi->param( 'q1', lc( $letter ) );
$href = $ENV{'SCRIPT_NAME'} . '?' . $tempCgi->query_string( );
$anchors .= &CGI::a( {-href => $href}, $letter ) . ' ';
}
# numbers
$tempCgi->param( 'chartype', 'num' );
$tempCgi->param( 'q1', '0' );
$href = $ENV{'SCRIPT_NAME'} . '?' . $tempCgi->query_string( );
$anchors .= &CGI::a( {-href => $href}, 'Numeric' ) . ' ';
# non-alphanumeric
$tempCgi->param( 'chartype', 'misc' );
$tempCgi->param( 'q1','_' );
$href = $ENV{'SCRIPT_NAME'} . '?' . $tempCgi->query_string( );
$anchors .= &CGI::a( {-href => $href}, 'Non-Alphabetic' );
my $class;
if ( exists( $$piParamHashRef{'class'} ) )
{ $class = $$piParamHashRef{'class'}; }
else
{ $class = 'bogus'; }
$quickLink .= &CGI::p( {-class => $class },
&CGI::b( $realmEng, ':' ),
$anchors );
}
return $quickLink;
}
# ----------------------------------------------------------------------
# NAME : _HandleStartPageProcIns
# PURPOSE :
# CALLED BY : _HandleStartPage
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _HandleStartPageProcIns
{
my ( $cgi, $cio, $htmlPageRef, $realmsRef, $realmsEngRef ) = @_;
# ProcIns object for use in filtering
my $pio = new ProcIns;
# wordwheel-specific substitutions
$pio->AddPI( 'Q1_INPUT', \&DlpsUtils::BuildTextInput, [ $cgi, 'q1' ] );
$pio->AddPI( 'WORDWHEEL_RADIO_GROUP', \&_BuildWWRadioGroup, [ $realmsRef, $realmsEngRef ] );
$pio->AddPI( 'WORDWHEEL_QUICK_LINK', \&_BuildWWQuickLink, [ $cgi, $realmsRef, $realmsEngRef ] );
# send off html page, by ref, to get processed
$htmlPageRef = $pio->ProcessPIs( $htmlPageRef );
}
# ----------------------------------------------------------------------
# NAME : _CleanCgiParameters
# PURPOSE : Clone the CGI and remove parameters we do not want to pass
# via links built by HandleGeneralProcIns()
# CALLED BY : _HandleXXXPage
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _CleanCgiParameters
{
my $cgi = shift;
# Clone the CGI and remove parameters we do not want to pass
# via links built by HandleGeneralProcIns()
my $cleanCgi = new CGI( $cgi );
$cleanCgi->delete( 'realm' );
$cleanCgi->delete( 'chartype' );
$cleanCgi->delete( 'top' );
$cleanCgi->delete( 'bottom' );
$cleanCgi->delete( 'down' );
$cleanCgi->delete( 'up' );
$cleanCgi->delete( 'q1' );
return $cleanCgi;
}
# ----------------------------------------------------------------------
# NAME : _HandleStartPage
# PURPOSE :
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _HandleStartPage
{
my ( $cgi, $dso, $cio, $realmsRef, $realmsEngRef ) = @_;
# Open template file
my $htmlPage = &DlpsUtils::GetHtmlTemplateText( $gPageParamToHtmlTpl{'wwstart'} );
# Clone the CGI and remove parameters we do not want to pass
# via links built by HandleGeneralProcIns()
my $cleanCgi = &_CleanCgiParameters( $cgi );
# Process re-authrization link (needs un-cleaned CGI)
&TextClassUtils::HandleReAuthLink( \$htmlPage, $cgi );
# Process PIs common to many pages
&TextClassUtils::HandleGeneralProcIns( \$htmlPage, $cleanCgi,
$cio, $gHtmlDocRoot, $dso );
# Process PIs specific to the WordWheel start page
&_HandleStartPageProcIns( $cgi, $cio, \$htmlPage, $realmsRef, $realmsEngRef );
# Send the page with http header prepended
&DlpsUtils::OutputHtmlPage( \$htmlPage );
}
# ----------------------------------------------------------------------
# NAME : _BuildWWRadioGroup
# PURPOSE :
# CALLED BY : PIO mechanism
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _BuildWWCombinedTableRows
{
my ( $cgi, $cio, $wwObj ) = @_;
my ( $arrayRef, $bestIndex ) = $wwObj->GetCombinedTable( );
my $numberOfRows = scalar( @{$arrayRef} );
my $t;
my $i;
my $mode = $wwObj->GetMode( );
my $emptyTable = 1;
for ( $i = 0; $i < $numberOfRows; $i++ )
{
my $rowColor;
if ( ( $mode eq 'new' ) && ( $i == $bestIndex ) )
{
$rowColor = '#CCCCCC';
}
else
{
$rowColor = '#FFFFFF';
}
my $word = $ {$$arrayRef[$i]}[0];
my $label = $word;
my $occur = $ {$$arrayRef[$i]}[1];
&DlpsUtils::FilterCharEnts_Misc( \$label );
&DlpsUtils::FilterCharEnts_ISO_Greek( \$label );
if ( $word )
{
$emptyTable = 0;
# Get list of already checked items
my @q1 = $cgi->param( 'q1' );
my $checked = ( grep( /^$word$/, @q1 ) ) ? 1 : 0;
# Turn off autoescaping so that the already HTML label
# shows up properly
&CGI::autoEscape( undef );
$t .= &CGI::Tr( {-bgcolor => $rowColor},
&CGI::td(
[
&CGI::checkbox( -name =>'q1',
-checked => $checked,
-value => $word,
-label => $label,
-force => 'force' ),
$occur
]
),
);
&CGI::autoEscape( 1 );
}
}
if ( $emptyTable )
{
$t = &CGI::Tr( {-bgcolor => '#FFFFFF'},
&CGI::td( ["Not Found", 0] )
);
}
return $t;
}
# ----------------------------------------------------------------------
# NAME : _HandleFullPageProcIns
# PURPOSE :
# CALLED BY : _HandleFullPage
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _HandleFullPageProcIns
{
my ( $cgi, $cio, $htmlPageRef, $realmsRef, $realmsEngRef, $chartype, $wwObj ) = @_;
# ProcIns object for use in filtering
my $pio = new ProcIns;
# wordwheel-specific substitutions
$pio->AddPI( 'Q1_INPUT', \&DlpsUtils::BuildTextInput, [ $cgi, 'q1' ] );
$pio->AddPI( 'WORDWHEEL_RADIO_GROUP', \&_BuildWWRadioGroup, [ $realmsRef, $realmsEngRef ] );
$pio->AddPI( 'WORDWHEEL_QUICK_LINK', \&_BuildWWQuickLink, [ $cgi, $realmsRef, $realmsEngRef ] );
$pio->AddPI( 'WORDWHEEL_UP_BUTTON', \&_BuildArrowLink, [ 'up', $chartype ] );
$pio->AddPI( 'WORDWHEEL_DOWN_BUTTON', \&_BuildArrowLink, [ 'down', $chartype ] );
$pio->AddPI( 'SIMPLE_SEARCH_LINK', \&TextUtils::ChangeNavLink, [ $cgi, 'page', 'simple' ] );
$pio->AddPI( 'WORDWHEEL_COMBINED_TABLE_ROWS', \&_BuildWWCombinedTableRows, [ $cgi, $cio, $wwObj ] );
# send off html page, by ref, to get processed
$htmlPageRef = $pio->ProcessPIs( $htmlPageRef );
}
# ----------------------------------------------------------------------
# NAME : _HandleFullPageHiddenProcIns
# PURPOSE :
# CALLED BY : _HandleFullPage
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES : Put AddPI( 'HIDDEN_REQUESTED_REALM', \&_BuildHiddenRealm, [ $wwObj ] );
$pio->AddPI( 'HIDDEN_REQUESTED_CHARTYPE', \&_BuildHiddenChartype, [ $wwObj ] );
$pio->AddPI( 'HIDDEN_REQUESTED_TOPBOTTOM', \&_BuildHiddenTopBottom, [ $wwObj ] );
$pio->AddPI( 'HIDDEN_CHECKED_ITEMS', \&_BuildHiddenCheckedItems, [ $cgi, $wwObj ] );
# send off html page, by ref, to get processed
$htmlPageRef = $pio->ProcessPIs( $htmlPageRef );
}
# ----------------------------------------------------------------------
# NAME : _HandleFullPage
# PURPOSE :
# CALLED BY : main
# CALLS : NONE
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _HandleFullPage
{
my ( $dso, $cgi, $cio, $realmsRef, $realmsEngRef, $chartype, $wwObj ) = @_;
# Open template file
my $htmlPage = &DlpsUtils::GetHtmlTemplateText( $gPageParamToHtmlTpl{'wwfull'} );
# Clone the CGI and remove parameters we do not want to pass
# via links built by HandleGeneralProcIns()
my $cleanCgi = &_CleanCgiParameters( $cgi );
# Process re-authrization link (needs un-cleaned CGI)
&TextClassUtils::HandleReAuthLink( \$htmlPage, $cgi );
# Process PIs common to many pages
&TextClassUtils::HandleGeneralProcIns( \$htmlPage, $cleanCgi,
$cio, $gHtmlDocRoot, $dso );
# Process PIs specific to the WordWheel full page
&_HandleFullPageProcIns( $cgi, $cio, \$htmlPage,
$realmsRef, $realmsEngRef,
$chartype, $wwObj );
# Build the hidden links to maintain state
&_HandleFullPageHiddenProcIns( \$htmlPage, $wwObj, $cgi );
# Send the page with http header prepended
&DlpsUtils::OutputHtmlPage( \$htmlPage );
}
# ----------------------------------------------------------------------
# NAME : _BuildHiddenRealm
# PURPOSE : create html for hidden realm=author, e.g.
# CALLED BY : PIO mechanism
# CALLS : CGI
# INPUT : realm
# RETURNS : html text
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _BuildHiddenRealm
{
my $wwObj = shift;
my $s = &CGI::hidden( -name =>'realm',
-default => $wwObj->GetRealm( ),
-override => 1 );
return $s;
};
# ----------------------------------------------------------------------
# NAME : _BuildHiddenChartype
# PURPOSE : create html for hidden chartype=alpha, e.g.
# CALLED BY : PIO mechanism
# CALLS : CGI
# INPUT : chartype
# RETURNS : html text
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _BuildHiddenChartype
{
my $wwObj = shift;
my $s = &CGI::hidden( -name =>'chartype',
-default => $wwObj->GetChartype( ),
-override => 1 );
return $s;
};
# ----------------------------------------------------------------------
# NAME : _BuildHiddenTopBottom
# PURPOSE : create html for hidden chartype=alpha, e.g.
# CALLED BY : PIO mechanism
# CALLS : CGI
# INPUT : chartype
# RETURNS : html text
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES : be careful override the URL parameter value, stored in
# the URL parsed implicitly by the implicit CGI object
# created when various CGI::subs are called
# ----------------------------------------------------------------------
sub _BuildHiddenTopBottom
{
my $wwObj = shift;
my ( $top, $bottom ) = $wwObj->GetTopBottom( );
my $t = &CGI::hidden( -name =>'top',
-default => $top,
-override => 1 );
my $b = &CGI::hidden( -name =>'bottom',
-default => $bottom,
-override => 1 );
return $t . $b
};
# ----------------------------------------------------------------------
# NAME : _BuildHiddenCheckedItems
# PURPOSE : create html for hidden q1=foo q1=bar, e.g.
# CALLED BY : PIO mechanism
# CALLS : CGI
# INPUT : $gCgi
# RETURNS : html text
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES : be careful override the URL parameter value, stored in
# the URL parsed implicitly by the implicit CGI object
# created when various CGI::subs are called
# ----------------------------------------------------------------------
sub _BuildHiddenCheckedItems
{
my ( $cgi, $wwObj ) = @_;
my @q1 = $cgi->param( 'q1' );
return if ( ! @q1 );
# Hidden for each q1 that is not in the window. Browser will
# supply q1 for each checked item in the window
my ( $arrayRef, $bestIndex ) = $wwObj->GetCombinedTable( );
my $numberOfRows = scalar( @{$arrayRef} );
my $hidden;
Q1:
foreach my $q1 ( @q1 )
{
my $i;
for ( $i = 0; $i < $numberOfRows; $i++ )
{
my $word = $ {$$arrayRef[$i]}[0];
next Q1 if ( $q1 eq $word );
}
$hidden .= &CGI::hidden( -name =>'q1',
-default => $q1,
-override => 1 ) . "\n";
}
return $hidden;
};
# ----------------------------------------------------------------------
# NAME : _BuildArrowLink
# PURPOSE :
# CALLED BY : PIO mechanism, _HandleFullPageProcIns
# CALLS : CGI
# INPUT : NONE
# RETURNS : NONE
# GLOBALS : NONE
# SIDE-EFFECTS :
# NOTES :
# ----------------------------------------------------------------------
sub _BuildArrowLink
{
my ( $direction, $chartype, $piParamHashRef ) = @_;
return &CGI::p( ' ' ) if ( $chartype ne 'alpha' );
my $src;
if ( exists( $$piParamHashRef{'src'} ) )
{ $src = $$piParamHashRef{'src'}; }
else
{ $src = 'bogus'; }
my $align;
if ( exists( $$piParamHashRef{'align'} ) )
{ $align = $$piParamHashRef{'align'}; }
else
{ $align = 'RIGHT'; }
my $alt;
if ( exists( $$piParamHashRef{'alt'} ) )
{ $alt = $$piParamHashRef{'alt'}; }
else
{ $alt = 'move around in the list'; }
my $border;
if ( exists( $$piParamHashRef{'border'} ) )
{ $border = $$piParamHashRef{'border'}; }
else
{ $border = '0'; }
my $hspace;
if ( exists( $$piParamHashRef{'hspace'} ) )
{ $hspace = $$piParamHashRef{'hspace'}; }
else
{ $hspace = '10'; }
my $vspace;
if ( exists( $$piParamHashRef{'vspace'} ) )
{ $vspace = $$piParamHashRef{'vspace'}; }
else
{ $vspace = '0'; }
my $width;
if ( exists( $$piParamHashRef{'width'} ) )
{ $width = $$piParamHashRef{'width'}; }
else
{ $width = '37'; }
my $link = &CGI::image_button( -name => $direction,
-src => $src,
-align => $align,
-alt => $alt,
-border => $border,
-hspace => $hspace,
-vspace => $vspace,
-width => $width );
return $link;
}
__END__;