package RFC::RFCCGI;
#$Id: RFCCGI.pm,v 1.137 2026/02/27 08:04:35 sqko Exp $
use strict;
use warnings;
use RFC::Header;
use RFC::Main;
use RFC::Rig;
use SocketClient;
use Time::HiRes qw(time);
use Sys::Hostname qw(hostname);
use CGI qw(:standard :netscape);
use Template;
use MIME::Base64;
require Exporter;

#################################################################################################
#
#
#  Package RFC::RFCCGI
#
# This module contains a number of utility functions for outputting properly formatted html code for
# user interface generation. Thus it mainly extends the CGI.pm module by Lincoln D. Stein.
# The module exports these functions in two groups.
#
# The :html group exports these functions:
#
# -- \begin{longtable}{ l p{10cm} }
# -- print_header($[\%]) & Prints the header information. Arguments: title. Any additional optional arguments (in the form of a hash) will be parsed along to the header() function supplied by CGI.pm. The functionautomatically appends a call to a javascript function logging users out after some time of no actions. \\
# -- print_end() & Prints the help button and ends the html output with the proper tag.  \\
# -- not_auth() & Prints the information supplied to the user if the user is nor authorised. Also prints a link to the log in page. \\
# -- xss($) & Wrapper for CGI::excapeHTML. \\
# -- print_hidden() & Prints a number of hidden fields used to maintain state. This includes user name and a cryptographic hash of the users password. \\
# -- print_hidden_rig() &  Same as print_hidden(), but with the additional information abut the active rig.\\
# -- logout() & Printys a logout button. \\
# -- action($) & Prints a hidden field with an action parameter with the specified value which can be used for program control flow.  \\
# -- RFC_start_html() & A wrapper for CGI::start_html. Any arguments (in the form of a hash) are passed to CGI::start_html. Automatically appends a reference to the javascript source file on the server. \\
# -- js_back() & Prints the javascript for gping backwards (uses the browser.back() fjavascrpt call). \\
# -- get_CGI_value($) & Retrieves the value of the specified CGI parameter (supplied by the web browser. \\
# -- get_CGI_value_clean($) & Same as get_CGI_value, but does pattern match on the retrieved value and only returns the part that matches. The pattern match is [{\backslash}w{\backslash}s{\backslash}.{\backslash},{\backslash}-]*. This has the benefit of untainting the returned parameter value (For taint checks in perl and web access, refer Lincoln D. Steins book \textit{Official Guide to Programming with CGI.pm}) \\
# -- rig_auth() & This function returns 1 if the user is certified for the rig in question. It only checks if the rig in question is mentioned in the 'safety_task_access' section in the global configuration Where each rig is supposed to define which taskid(s) are connected with which rig. If more than one taskid is connected with the rig (specified by a list of id numbers), the user has to be authentificated for all taskids in the list for authentification to occour. The definition is in the form:  rig1 = 45,1 where 45 and 1 are the taskids to check against. Usage is either with named rig argument or without any argument, if used without argument, the current rig number is used as default. Usage: rig_auth(), rig_auth($rig) or rig_auth($rig,$taskidstring). If the last call method is used the taskidstring must be a string of integers seperated by comma. \\
# -- rig_cert() & This function returns 1 if the user is certified for the rig in question. It only checks if the rig in question is mentioned in the 'safety_task_access' section in the global configuration Where each rig is supposed to define which taskid(s) are connected with which rig. If more than one taskid is connected with the rig (specified by a list of id numbers), the user has to be certified for the first in the list for certification to occour. The definition is in the form: rig1 = 45,1 where 45 is the taskid to check against. Usage is either with named rig argument or without any argument, if used without argument, the current rig number is used as default. Usage: rig_cert() or rig_cert($rig). \\
# -- rig_auth_nocgi($$) & Similar to rig_auth(), but the rig number and username must be specified. \\
# -- rig_cert_nocgi($$) & Similar to rig_cert(), but the rig number and username must be specified. \\
# -- rig_data_access_allow([$]) & Returns 1 if the user is allowed to access historical data for the rig in question. If an optional argument is specified, this is the username to check for.\\
# -- rig_data_test_access_allow($$[$]) & Returns true if the user is allowed to access the specified rig and test data. If an optional third argument is specified, this is the username to check for.\\
# -- \end{longtable}
#
#
# The :cgi group of functions include the following:
#
# -- \begin{longtable}{ l p{10cm} }
# -- get_CGI_value($) & See above. \\
# -- get_CGI_value_clean($) &  See above. \\
# -- rig_cert() & See above \\
# -- rig_auth() & See above \\
# -- action($) & See above \\
# -- not_auth() & See above \\
# -- xss($) & See above \\
# -- login_ok() & Checks if the user supplied login credentials are ok. This can be either against a small local database, or against a full RDBMS. \\
# -- menu_button(@) & Prints a menu button. Arguments: name, value, style. The name will be the CGI parameter name, the value vill be the text on the button and the style is a style class name to use for displaying. \\
# -- top_nav_bar_start() & Prints the html tags to start the top navigation bar (table specifications etc.) \\
# -- top_no_button() & Prints a no action button (goes nowhere) in the top navigation bar. \\
# -- top_nav_bar_button() & prints a top navigation button. Arguments: File, name, value, style, [optional additional name, value and force triplets]. The file is the cgi-script to be called upon button press, the name,value and style arguments are passed to menu_button() and the additional optional arguments are used to initialise and print hidden html fields in the form of name-value pairs and a force argument (1 for force value, 0 for allow reuse of value). \\
# -- tab_newrow() & Prints a new row in the top navigation bar. \\
# -- top_js_return() & Prints a top navigation return button (uses the javascript printed by js_back(), see above) \\
# -- end_top_bar() & Prints the end of the top navigation bar. \\
# -- is_logout_time() & Returns 1 or 0 depending on time since last action by the current user (used for authentification purposes). Deprecated from version 4.6.2 onwrads!\\
# -- is_admin() & Return 1 if the current user is an administrator (gets explicit access) \\
# -- user_auth() & Returns 1 if the user is authorised for the rig in question. Some of the authentification is forwarded to rig_auth() \\
# -- get_user() & Returns the username of current user. \\
# -- get_pass() & Returns the cryptographic hash of the current users password. \\
# -- logout_delay() & returns the number of minutes a user can remain inactive before automatic logout occours. \\
# -- process($$) & processes the specified template with the specified data structure (a reference). If no data reference is specified, the default from get_template_data_ref() is used instead.\\
# -- get_template_data_ref($) & Returns a data structure suitable for processing by process(). If an argument is specified it as to be either a hash reference or an array reference (and will be avaliable as the list or data field from within the template).\\  
# -- get_template_data_ref_nocheck($) & Returns a data structure suitable for processing by process(). If an argument is specified it as to be either a hash reference or an array reference (and will be avaliable as the list or data field from within the template). Doed NOT check for valid rig!\\  
# -- \end{longtable}
#
#
# An additional function which is often used (but which is not exported by default) is the
# print_js_validate() function. 
# This function prints a javascript function for client side input validation.
# The function can check any number of fields (names specified in the arguments list) 
# and can either check if a field is filled out, OR check that if a field value is 'NEW' 
# then an other field must not be empty The syntax for this case is: 'name_1#name_2' where
# name_1 is the name of the field which can be 'NEW' and name_2 is the name of field 2 
# which must not be empty. Another form of check is where a number of fields      
# exists and where not all fields can be empty to use this option use the ':' separator
# in the string: '$field_group_name:$field1:$field2:...'.
#
# Usage:  print_js_validate($form_name,[$field_names...]) It is also possible to include 
# regular expression tests in the validation. To do this use the format: 
# 'name;"regexp";[opt $]Error message'. If the $ is the value of the input field is placed 
# in front of the errormessage!                                           
#
#
#################################################################################################



BEGIN {
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
    $VERSION = 1.0;
    @ISA = qw(Exporter);
    @EXPORT = qw($homedir $userdir);
    @EXPORT_OK = qw($name top_nav_bar_button print_header print_end not_auth print_hidden logout login_ok action get_user RFC_start_html print_id js_back get_CGI_value get_CGI_value_clean js_back login_ok menu_button not_auth top_no_button tab_newrow action end_top_bar top_nav_bar_start top_js_return is_logout_time get_id is_admin user_auth get_user get_pass print_hidden_rig rig_cert rig_auth xss ssx process get_template_data_ref rig_data_access_allow rig_data_test_access_allow get_template_data_ref_nocheck get_cache set_cache);
    %EXPORT_TAGS = (
		    html => [ qw($name print_header print_end not_auth print_hidden print_hidden_rig logout action RFC_start_html js_back get_CGI_value get_CGI_value_clean rig_cert rig_auth xss process rig_data_access_allow rig_data_test_access_allow set_cache get_cache) ],
		    cgi => [ qw(login_ok get_CGI_value get_CGI_value_clean menu_button top_no_button tab_newrow action end_top_bar top_nav_bar_start top_js_return top_nav_bar_button not_auth is_logout_time get_id is_admin user_auth get_user get_pass rig_cert rig_auth xss process get_template_data_ref rig_data_access_allow rig_data_test_access_allow get_template_data_ref_nocheck set_cache get_cache) ],
                    );
}

my $start = time;
our $name = $RFC::Header::COPYRIGHT.' RFCcontrol';
our $path = $RFC::Header::publicdir.'celltest/templates/';
my $userref = {};
my $rigref = {};
my $navref = {};
my $tt;
our $template_data = {};
our $config_data_ref = undef;
our $rig_config_data_ref = undef;
my $config = ElchemeaConfig->new($configfile,$configlock);

my %cache = ();

my $msg = '';

return 1;

sub rig_data_test_access_allow($$)
{
    my $r = shift;
    my $test = shift;
    my $u = undef;
    if (@_)
    {
	$u = shift;	
    }
    else
    {
	$u = &get_user();
    }
    my $auth = &rig_data_access_allow($u,$r);
    return $auth if ($auth);
    $auth = &get_cache($u,$r.'test'.$test);
    return $auth if (defined($auth));
    my $userref = &get_user_data_ref();
    my $rig = RFC::Rig->new($r,0,'nocheck');
    my $eqid = $rig->get_cv('main','equipmentid');
    my $remote = $rig->get_cv('main','authorisation');
    if ($eqid && $remote && $remote =~ /remote/i)
    {
	$auth = &RFC::Main::passwd_client('can_read_test',$u,$eqid,$test);
	$auth = undef if ($auth && $auth < 0);
	$auth = undef if (defined($auth) && $auth eq '');
	if ($auth)
	{
	    &set_cache($u,$r.'test'.$test,$auth);
	    return $auth;
	}
    }
    my $dir = $rig->webdir($test);
    if ($$userref{'auth'} && $test == $rig->session() && &get_cv('global','allow_access_current_test_to_auth_users') && &get_cv('global','allow_access_current_test_to_auth_users') =~ /yes/i)
    {
	&set_cache($u,$r.'test'.$test,1);
	return 1;
    }
    my $f = $dir.'proglog';
    my $start_by = undef;
    if ($f && -e $f)
    {
	open MYIN,'<',$f or die "Cant open file $f for reading $!";
	my $str = <MYIN>;
	close MYIN;
	if ($str && $str =~ /user\s\'(\w+)\'/)
	{
	    $start_by = $1;
	}
    }
    unless ($start_by)
    {
	## Try info.txt ##
	my $f = $dir.'info.txt';
	if ($f && -e $f)
	{
	    my $cp = 0;
	    open MYIN,'<',$f or die "Cant open file $f for reading $!";
	    while (my $str = <MYIN>)
	    {
		if ($str && $str =~ /started\s+by\:\s+(\w+)/)
		{
		    $start_by = $1;
		    last;
		}
		last if ($cp++ > 20);
	    }
	    close MYIN;
	}	
    }
    ## Allow 'owner' access ##
    if ($start_by && $start_by eq $u)
    {
	&set_cache($u,$r.'test'.$test,1);
	return 1;
    }
    ## Check for restrinctions on directory ##
    my $allow = $auth;
    $f = $dir.'.restrict';
    if (-e $f)
    {
	open MYIN,'<',$f or die "Could not open file $f: $!\n";
	my @lines = <MYIN>;
	close MYIN;
	foreach my $l (@lines)
	{
	    next if ($l && $l =~ /^[\s\t]*#/);
	    next unless ($l && $l =~ /allow\s+\=\s+([\s\d\,]+)/);
	    my $auth = $1;
	    my @list = ();
	    @list = split(/\s*\,\s*/,$auth);
	    if (@list)
	    {
		$allow = 0;
		foreach my $id (@list)
		{
		    ## Allow is user is authorised for at least one of the listed authorisations                                                        
		    next if ($allow);
		    $allow = &RFC::Main::passwd_client('safety_auth',$u,$id);
		}
	    }
	    last;
	}
	$auth = $allow;
    }
    ## Set cache ##
    $auth = 0 unless ($auth);
    &set_cache($u,$r.'test'.$test,$auth);
    return $auth;
}

sub rig_data_access_allow()
{
    my $u = undef;
    if (@_)
    {
	$u = shift;	
    }
    else
    {
	$u = &get_user();
    }
    my $allow = undef;
    my $uid = 0;
    my $r = undef;
    if (@_)
    {
	$r = shift;	
    }
    else
    {
	$r = param('rig');
    }
    $allow = &get_cache($u,$r);
    return $allow if (defined($allow));
    if ($r)
    {
	my $rig = RFC::Rig->new($r,0,'nocheck');
	my $eqid = $rig->get_cv('main','equipmentid');
	my $remote = $rig->get_cv('main','authorisation');
	if ($eqid && $remote && $remote =~ /remote/i)
	{
	    $allow = &get_cache($u,$r.'_read_data');
	    if (defined($allow))
	    {
		return $allow;
	    }
	    $allow = &RFC::Main::passwd_client('can_read_data',$u,$eqid);
	    ## Handle no-connect errors etc ##
	    $allow = undef if ($allow && $allow < 0);
	    $allow = undef if (defined($allow) && $allow eq '');
	    ## Set default deny ##
	    $allow = 0 unless (defined($allow));
	}
    }
    my $ac = &get_cv('global','only_allow_explicit_data_access');
    if ($ac && $ac =~ /yes/i)
    {
	&set_cache($u,$r,$allow);
	return $allow; 
    }
    my @authids = &get_cv('global','data_access_authorisationid');
    if (@authids)
    {
	if ($u)
	{
	    foreach my $id (@authids)
	    {
		&get_cache($u,$id);
		next if ($allow);
		$allow = &RFC::Main::passwd_client('safety_auth',$u,$id);
		&set_cache($u,$id,$allow);
	    }
	    &set_cache($u,$r,$allow);
	    return $allow;
	}
	else
	{
	    ## Deny if user does not validate
	    $allow = 0;
	}
    }
    else
    {
	## Default allow if no access restrinctions is set up
	$allow = 1;
    }
    &set_cache($u,$r,$allow);
    return $allow;
}


sub init_tt
{
    return undef if ($tt);
    $tt = Template->new({
    INCLUDE_PATH => $path,
    INTERPOLATE  => 1,
    RECURSION => 1,
    RELATIVE => 1,
			}) or die "$Template::ERROR\n";
    return undef;
}


sub process
{
    my $tfile = shift;
    my $data = shift;
    &init_tt();
    $data = &get_template_data_ref() unless ($data);
    my $result = '';
    $tt->process($tfile,$data,\$result) or die $tt->error();
    my $str = "\n\n<!-- Done processing $path/$tfile -->\n\n";
    return $result.$str;
}



sub get_config_data_ref()
{
    return $config_data_ref if ($config_data_ref);
    my %data = ();
    foreach my $section ($config->get_sections())
    {
        my %secdata = ();
        foreach my $key ($config->get_keys($section))
        {
            $secdata{$key} = $config->get_config_value($section,$key);
        }
        $data{$section} = \%secdata;
    }
    $config_data_ref = \%data;
    return $config_data_ref;
}


sub get_rig_config_data_ref()
{
    return $rig_config_data_ref if ($rig_config_data_ref);
    my %data = ();
    my $rigref = &get_rig_data_ref();
    if ($$rigref{'rig'})
    {
	my $conf = $$rigref{'rig'}->config();
	foreach my $section ($conf->get_sections())
	{
	    my %secdata = ();
	    foreach my $key ($conf->get_keys($section))
	    {
		$secdata{$key} = $conf->get_config_value($section,$key);
	    }
	    $data{$section} = \%secdata;
	}
	$rig_config_data_ref = \%data;	
    }    
    return $rig_config_data_ref;
}

sub get_nav_ref()
{
    unless ($navref && keys %{$navref})
    {
        my %h = ('pid' => $$);
        foreach my $key (param())
        {
            my $val = param($key);
            next unless (defined($val));
            $h{$key} = $val;        
        }
	$navref = \%h;
    }
    return $navref;
}


sub get_template_data_ref
{
    my $ptime = time - $start;
    my $sname = &get_cv('global','server_name');
    $sname = hostname() unless ($sname);
    my $ssl = CGI::https();
    $ssl = 0 unless ($ssl);
    my %h = (
        user_info => &get_user_data_ref(),
        rig_info => &get_rig_data_ref(),
        global_config => &get_config_data_ref(),
        config => &get_rig_config_data_ref(),
        data => $template_data,
        list => [],
        nav => &get_nav_ref(),
        process_time => $ptime,
	hostname => hostname(),
	servername => $sname,
	ssl => $ssl,
	);
    if (-e $RFC::Header::furnacedir)
    {
	$h{'RFCfurnace'} = 1;
    }
    if (@_)
    {
        my $ref = shift;
        if (ref($ref) eq 'ARRAY')
        {
            $h{'list'} = $ref;
        }
        if (ref($ref) eq 'HASH')
        {
            $h{'data'} = $ref;
        }
    }
    my $ref = \%h;
    &myxss($ref);
    return $ref;
}



sub get_template_data_ref_nocheck
{
    my $ptime = time - $start;
    my %h = (
        user_info => &get_user_data_ref('nocheck'),
        rig_info => &get_rig_data_ref(),
        global_config => &get_config_data_ref(),
        config => &get_rig_config_data_ref(),
        data => $template_data,
        list => [],
        nav => &get_nav_ref(),
        process_time => $ptime,
	hostname => hostname(),
	);
    if (@_)
    {
        my $ref = shift;
        if (ref($ref) eq 'ARRAY')
        {
            $h{'list'} = $ref;
        }
        if (ref($ref) eq 'HASH')
        {
            $h{'data'} = $ref;
        }
    }
    my $ref = \%h;
    &myxss($ref);
    return $ref;
}

sub myxss($)
{
    my $ref = shift;
    if (ref($ref) eq 'ARRAY')
    {
        foreach my $i (@{$ref})
        {
            next unless(defined($i));
            &myxss($i);
        }
        return;
    }
    if (ref($ref) eq 'HASH')
    {
        foreach my $key (keys %{$ref})
        {
            next unless (defined($$ref{$key}));
            if (ref($$ref{$key}))
            {
                &myxss($$ref{$key});
                next;
            }
            ## Do NOT url-escape links ##
            next if ($key eq 'url' || $key eq 'link');
            $$ref{$key} = escapeHTML($$ref{$key});
        }
        return;
    }
    $ref = escapeHTML($ref);
}

sub get_rig_data_ref()
{
    return $rigref if ($rigref && keys %{$rigref});
    my $rig = &get_CGI_value_clean('rig');
    if ($rig)
    {
	$$rigref{'name'} = $rig;
	my $r = RFC::Rig->new($rig);
	$$rigref{'rig'} = $r;
	$$rigref{'current_test'} = $r->session();
    }
    return $rigref;
}

sub get_user_data_ref()
{
    my $rig = &get_CGI_value_clean('rig');
    return $userref if ($userref && keys %{$userref});
    ($$userref{'name'},$$userref{'pass'}) = &get_id();
    $$userref{'uid'} = &user_ok();
    $$userref{'admin'} = &get_cache($$userref{'name'},'admin');
    unless (defined($$userref{'admin'}))
    {
	$$userref{'admin'} = &is_admin();
	&set_cache($$userref{'name'},'admin',$$userref{'admin'});
    }
    $$userref{'remote'} = &rig_mode($rig,@_) if ($rig);
    my $acmode = $config->get_config_value('global','access_mode');
    $acmode = 'celltest' unless ($acmode);
    $$userref{'access_mode'} = $acmode;
    if ($$userref{'admin'})
    {
	$$userref{'auth'} = 1;
	$$userref{'cert'} = 1;	
    }
    else
    {
	if ($rig)
	{
	    $$userref{'auth'} = &get_cache($$userref{'name'},$rig.'_auth');
	    $$userref{'cert'} = &get_cache($$userref{'name'},$rig.'_cert');
	}
	else
	{
	    $$userref{'auth'} = &get_cache($$userref{'name'},'auth');
	    $$userref{'cert'} = &get_cache($$userref{'name'},'cert');
	}
	unless (defined($$userref{'auth'}) && defined($$userref{'cert'}))
	{
	    if ($$userref{'remote'})
	    {
		my $authid = 0;
		if ($rig)
		{
		    my $rr = RFC::Rig->new($rig,0,@_);
		    $authid = $rr->get_cv('main','authorisationid');
		}
		if ($authid)
		{		
		    if (&RFC::Main::get_soap)
		    {
			$$userref{'auth'} = &passwd_client('safety_auth',$$userref{'name'},$authid); 
			$$userref{'cert'} = &passwd_client('safety_cert',$$userref{'name'},$authid);
		    }
		    else
		    {
			$$userref{'auth'} = &passwd_client('check_task_status',$$userref{'name'},$authid);
			$$userref{'cert'} = &passwd_client('check_task_cert',$$userref{'name'},$authid);
		    }
		}
		else
		{
		    $$userref{'auth'} = &rig_auth();
		    $$userref{'cert'} = &rig_cert();	
		}
	    }
	    else
	    {
		$$userref{'auth'} = &user_auth($$userref{'access_mode'},'c');
		$$userref{'cert'} = &user_auth($$userref{'access_mode'},'m');	
	    }
	    if ($rig)
	    {
		&set_cache($$userref{'name'},$rig.'_auth',$$userref{'auth'});
		&set_cache($$userref{'name'},$rig.'_cert',$$userref{'cert'});
	    }
	    else
	    {
		&set_cache($$userref{'name'},'auth',$$userref{'auth'});
		&set_cache($$userref{'name'},'cert',$$userref{'cert'}); 
	    }	    
	}
    }
    my $authid = $config->get_config_value('global','report_authorisationid');
    if ($authid)
    {
	$$userref{'allow_search_reports'} = &get_cache($$userref{'name'},$authid);
	unless (defined($$userref{'allow_search_reports'}))
	{
	    $$userref{'allow_search_reports'} = &passwd_client('safety_auth',$$userref{'name'},$authid);
	    &set_cache($$userref{'name'},$authid,$$userref{'allow_search_reports'}); 
	}
    }
    my $furnace_start_id = &RFC::Main::get_cv('global','authorisation_change_allow_start');
    if ($furnace_start_id && $furnace_start_id > 0)
    {
	my $local_admin = &get_cache($$userref{'name'},$furnace_start_id);
	unless (defined($local_admin))
	{
	    $local_admin = &RFC::Main::passwd_client('safety_auth_nolabtech',$$userref{'name'},$furnace_start_id);
	    $local_admin = 0 unless ($local_admin && $local_admin > 0);
	    &set_cache($$userref{'name'},$furnace_start_id,$local_admin); 
	}
	$$userref{'allow_start_stop'} = $local_admin;
    }
    my $allow = 0;
    my $allow_log = 0;
    my $auth = &get_cv('global','restrict_access_auth_only');
    if ($auth && $auth =~ /yes/)
    {
	$allow = &rig_data_access_allow($$userref{'name'},$rig);
        $allow_log = 0;
    }
    else
    {
        $allow = 1;
        $allow_log = 1;
    }
    unless ($$userref{'uid'})
    {
	$allow = 0;
        $allow_log = 0;
    }
    $$userref{'allow_log'} = $allow_log;
    $$userref{'allow'} = $allow;
    my $time = &logout_delay();
    $time = 10 unless ($time);
    if ($time =~ /(\d+)/)
    {
	$time = $1;
    }
    $time = ($time * 60 * 1000) - 10000;
    my $use_time = 1;
    $use_time = 0 if ($config->get_config_value('global','use_time') && $config->get_config_value('global','use_time') =~ /no/i);
    $$userref{'logout_time'} = $time;
    $$userref{'use_time'} = $use_time;
    return $userref;
}

sub get_cache
{
    my @l = @_;
    foreach (@l)
    {
	$_ = '' unless defined($_);
    }
    my $key = join('#',@l);
    if (exists($cache{$key}))
    {
	return $cache{$key} 
    }
    my $auth = undef;
    eval {
	$auth = SocketClient::socket_client_raw('localhost',4042,'get_auth',@l);
	$auth = undef if (defined($auth) && $auth eq '');
    };
    if ($@)
    {
	## Ignore if auth cache server is not running ##
    }
    if (defined($auth))
    {
	$cache{$key} = $auth;
    }
    return $auth;
}

sub set_cache
{
    my $val = pop;
    return unless (defined($val));
    my @l = @_;
    foreach (@l)
    {
	$_ = '' unless defined($_);
    }    
    my $key = join('#',@l);
    eval {
	SocketClient::socket_client_raw('localhost',4042,'set_auth',@l,$val);
    };
    if ($@)
    {
	warn $@;
	## Ignore if auth cache server is not running ##
    }
    $cache{$key} = $val;
}




sub xss($)
################################################################
#### Quote the supplied string to remove potential dangerous ###
#### XSS markup                                              ###
#### Returns a sanitized version of the supplied string      ###
################################################################
{
    my $str = shift;
    return escapeHTML($str);
}

sub ssx($)
################################################################
#### Inverts any xss sanitation (nescesarry for database     ###
#### searches                                                ###
#### Returns a usanitized version of the supplied string     ###
################################################################
{
    my $str = shift;
    return CGI::unescapeHTML($str);
}


sub is_logout_time
######################################################################
### Function which returns 1 if the login timeout time is exceeded ###
### If $use_time = 0 the function always returns 0                 ###
######################################################################
### Deprecated from 4.6.2 onwards                                  ###
######################################################################
{
    my $time = &time_string(&get_time("now"));
    my $logouttime = 0;
    $logouttime = param('time');
    my $res = 0;
    if ($time > $logouttime)
    {
        return 1;
    }
    return 0;
}

sub logout_delay()
{
    return &passwd_client('logout_delay');
}

sub login_ok()
#################################################################
### this function checks if the user and password obtained    ###
### from the web request is in order and that not too long    ###
### since last action has occured                             ###
#################################################################
{
    my ($user,$pass) = &get_id();
    my $uid;
    eval {
	$uid = SocketClient::socket_client_raw('localhost',4042,'login_ok',$user,$pass);
    };
    if ($@)
    {
	## Ignore if auth cache server is not running ##
	return &user_ok(@_)
    }
    return $uid;
}

sub user_ok()
#################################################################
### this function checks if the user and password obtained    ###
### from the web request is in order (CGI_wraper for user_ok) ###
### Any arguments is passed along to get_id()                 ###
#################################################################
{
    my ($user,$pass) = &get_id();
    $user = shift if (@_);
    $pass = shift if (@_);
    ### No need to check if nothing is specified
    return 0 unless ($user && $pass);
    my $res = &passwd_client('checkuser',$user,$pass);
    chomp $res if (defined($res));
    return 0 if (!defined($res) || $res =~ /error/i || $res < 0);
    return $res if ($res);
    my $token = '';
    my $str = &passwd_client('checkuser_sso',$user,$pass);
    ($res,$token) = split(/\n/,$str) if ($str);
    return 0 if (!defined($res) || $res =~ /error/i || $res < 0);
    param(-name=>'pass',-value=>$token) if ($token);
    return $res;
}

sub user_auth($$)
#######################################################
### CGI-wrapper for user_auth, gets the username by ###
### calling get_user.                               ###
### Usage: user_auth($table,$mode)                  ###
#######################################################
{
    my $tab = shift;
    my $mode = shift;
    my $m = 0;
    $m = 1 if ($mode eq 'r');
    $m = 2 if ($mode eq 'c');
    $m = 3 if ($mode eq 'm');
    my ($u,$p) = &get_id();
    ### No need to check if nothing is specified
    return 0 unless ($u && $p && $tab && $m);
    my $cache;
    eval {
	$cache = SocketClient::socket_client_raw('localhost',4042,'get_auth',$u,$tab);
    };
    if ($@)
    {
	$cache = undef;
	## Ignore if auth cache server is not running ##	
    }
    return $cache if (defined($cache) && $cache =~ /\d/);
    my $res = &passwd_client('checkauth',$u,$p,$tab,$m);
    chomp $res;
    $res = 0 if (!defined($res) || $res < 0);
    eval {
	SocketClient::socket_client_raw('localhost',4042,'set_auth',$u,$tab,$res);
    };
    if ($@)
    {
	## Ignore if auth cache server is not running ##	
    }    
    return $res;
}

sub is_admin()
##################################################################
### this function checks if the user and password obtained     ###
### from the web request is in order (CGI_wraper for is_admin) ###
### Any arguments is passed along to get_user()                ###
##################################################################
{
    my ($user,$pass) = &get_id(@_);
    ### No need to check if nothing is specified
    return 0 unless ($user && $pass);
    my $uid = 0;
    eval {
	$uid = SocketClient::socket_client_raw('localhost',4042,'is_admin',$user,$pass);
	die if ($uid && $uid =~ /error/i);
    };
    if ($@)
    {
	## Ignore if auth cache server is not running ##	
	chomp $user;
	my $res = &passwd_client('isadmin',$user,$pass);
	chomp $res;
	$res = 0 if (!defined($res) || $res < 0);
	return $res;
    }
    return $uid;
}

sub is_user($)
##################################################################
### this function checks if the user already exsists           ###
### Is a client-server wrapper for is_user_server()            ###
##################################################################
{
    my $user = shift;
    chomp $user;
    my $res = &passwd_client('isuser',$user);
    chomp $res;
    return $res;
}

sub get_email()
################################################################
#### This function is a wrapper for get_email() where the    ###
#### user is found from get_user()                           ###
################################################################
{
    my $user = &get_user();
    my $res = &passwd_client('email',$user);
    chomp $res;
    return $res;
}


sub rig_auth
##########################################################
### This function returns 1 if the user is authorised  ###
### to access the rig in question. It only checks if   ###
### the rig in question is mentioned in the 'safety_   ###
### task_access' section in the global configuration   ###
### Where each rig is supposed to define which taskid  ###
### is connected with which rig.                       ###
### in the form:  rig1 = 45    where 45 is the taskid  ###
### Usage is either with named rig argument or without ###
### any argument, if used without argument, the        ###
### current rig number is used as default.             ###
### Usage: CGI_rig_auth() or CGI_rig_auth($rig).       ###
### If the equpmentid and authorisation keys in the    ###
### main section is defined, the authorisation check   ###
### is performed by the 'equip_auth' check on the      ###
### remote password server instead (not supported by   ###
### the password server supplied by RFCcontrol).       ###
##########################################################
{
    my $rig = &get_CGI_value_clean('rig');
    my $user = &get_user();
    return &rig_auth_nocgi($rig,$user,@_);
}

sub rig_auth_nocgi
{
    my $rig = shift;
    my $user = shift;
    my $rr = undef;
    if (@_)
    {
	my $r = shift;
	if (ref($r) eq 'RFC::Rig')
	{
	    $rig = $r->name;
	    $rr = $r;
	}
	else
	{
	    $rig = $r;
	}
    }
    else
    {
	$rr = RFC::Rig->new($rig);
    }
    $rig =~ s/[\r\n]*//g if (defined($rig));
    $rr = RFC::Rig->new($rig) unless ($rr);
    my $eqid = $rr->get_cv('main','equipmentid');
    my $remote = $rr->get_cv('main','authorisation');
    my $cache;
    if ($eqid && $remote && $remote =~ /remote/i)
    {
	eval {
	    $cache = SocketClient::socket_client_raw('localhost',4042,'get_auth',$user,$eqid);
	};
	if ($@)
	{
	    $cache = undef;
	    ## Ignore if auth cache server is not running ##	
	}
	return $cache if ($cache);
	### Use remote autorisation method ##
	my $res = &passwd_client('equip_auth',$user,$eqid);
	if ($res != -1)
	{
	    eval {
		SocketClient::socket_clie_rawnt('localhost',4042,'set_auth',$user,$eqid,$res);
	    };
	    if ($@)
	    {
		## Ignore if auth cache server is not running ##	
	    }    
	    return $res;
	}
    }
    my $taskid = &get_cv('safety_task_access','rig'.$rig);
    $taskid = shift if (@_);
    return 1 unless (defined($taskid) && $taskid);
    return 1 if ($taskid =~ /NONE/); ## Specproc for override ###
    my $retval = 1;
    ### Run through all taskids in list and return 1 if all is ok ###
    foreach my $tid (split(/\s*\,\s*/,$taskid))
    {
	my $res;
	if (&RFC::Main::get_soap)
	{
	    eval {
		$res = SocketClient::socket_client_raw('localhost',4042,'get_auth',$user,$tid);
	    };
	    if ($@)
	    {
		$res = undef;
		## Ignore if auth cache server is not running ##	
	    }
	    unless (defined($res))
	    {
		$res = &passwd_client('safety_auth',$user,$tid);
		eval {
		    SocketClient::socket_client_raw('localhost',4042,'set_auth',$user,$tid,$res);
		};
		if ($@)
		{
		    ## Ignore if auth cache server is not running ##	
		}    
	    }
	}
	else
	{
	    eval {
		$res = SocketClient::socket_client_raw('localhost',4042,'get_auth',$user,$tid);
	    };
	    if ($@)
	    {
		$res = undef;
		## Ignore if auth cache server is not running ##	
	    }
	    unless (defined($res))
	    {
		$res = &passwd_client('check_task_status',$user,$tid);
		eval {
		    SocketClient::socket_client_raw('localhost',4042,'set_auth',$user,$tid,$res);
		};
		if ($@)
		{
		    ## Ignore if auth cache server is not running ##	
		}    
	    }
	}
	if (!defined($res) || $res < 0)
	{
	    &errorlog("Check_task_status for task $tid did not return expected value: returned: $res instead!");
	    return 0;
	}
	$retval = 0 unless ($res);
    }
    return $retval;
}


sub rig_cert
##########################################################
### This function returns 1 if the user is certified   ###
### for the rig in question. It only checks if         ###
### the rig in question is mentioned in the 'safety_   ###
### task_access' section in the global configuration   ###
### Where each rig is supposed to define which taskid  ###
### is connected with which rig.                       ###
### in the form:  rig1 = 45    where 45 is the taskid  ###
### Usage is either with named rig argument or without ###
### any argument, if used without argument, the        ###
### current rig number is used as default.             ###
### Usage: CGI_rig_auth() or CGI_rig_auth($rig).       ###
### If the equpmentid and authorisation keys in the    ###
### main section is defined, the authorisation check   ###
### is performed by the 'equip_auth' check on the      ###
### remote password server instead (not supported by   ###
### the password server supplied by RFCcontrol).       ###
##########################################################
{
    my $rig = &get_CGI_value_clean('rig');
    my $user = &get_user();
    return &rig_cert_nocgi($rig,$user,@_);
}

sub rig_cert_nocgi
{
    my $rig = shift;
    my $user = shift;
    my $rr = undef;
    if (@_)
    {
	my $r = shift;
	if (ref($r) eq 'RFC::Rig')
	{
	    $rig = $r->name;
	    $rr = $r;
	}
	else
	{
	    $rig = $r;
	}
    }
    else
    {
	$rr = RFC::Rig->new($rig);
    }
    $rig =~ s/[\r\n]*//g if (defined($rig));
    $rr = RFC::Rig->new($rig) unless ($rr);
    my $eqid = $rr->get_cv('main','equipmentid');
    my $remote = $rr->get_cv('main','authorisation');
    if ($eqid && $remote && $remote =~ /remote/i)
    {
	### Use remote autorisation method ##
	my $res = &passwd_client('equip_cert',$user,$eqid);
	return $res if ($res != -1);
    }
    my $taskid = &get_cv('safety_task_access','rig'.$rig);
    return 1 unless (defined($taskid) && $taskid);
    return 1 if ($taskid =~ /NONE/); ## Specproc for override ###
    my @tlist = split(/\s*\,\s*/,$taskid);
    ### Only check the first item in the taskid list for certification ###
    my $ok;
    if (&RFC::Main::get_soap)
    {
	$ok = &passwd_client('safety_cert',$user,$tlist[0]);
    }
    else
    {
	$ok = &passwd_client('check_task_cert',$user,$tlist[0]);
    }
    return $ok unless ($ok < 0);
    &errorlog("Check_task_status did not return expected value: returned: $ok instead!");
    return 0;
}


sub rig_mode()
##########################################################
### CGI_rig_mode returns 1 or 0 depending on if        ###
### the rig in question is mentioned in the 'safety_   ###
### task_access' section in the global configuration   ###
### Where each rig is supposed to define which taskid  ###
### is connected with which rig.                       ###
### in the form:  rig1 = 45    where 45 is the taskid  ###
### Usage is either with named rig argument or without ###
### any argument, if used without argument, the        ###
### current rig number is used as default.             ###
### Usage: CGI_rig_auth() or CGI_rig_auth($rig)        ###
##########################################################
{
    my $rig = &get_CGI_value_clean('rig');
    my $rr = undef;
    if (@_)
    {
	my $r = shift;
	if (ref($r) eq 'RFC::Rig')
	{
	    $rig = $r->name;
	    $rr = $r;
	}
	else
	{
	    $rig = $r;
	    $rr = RFC::Rig->new($rig,0,@_);
	}
    }
    else
    {
	$rr = RFC::Rig->new($rig);
    }
    $rig =~ s/[\r\n]*//g if (defined($rig));
    my $taskid = &get_cv('safety_task_access','rig'.$rig);
    return 1 if ($taskid);
    my $eqid = $rr->get_cv('main','equipmentid');
    my $authid = $rr->get_cv('main','authorisationid');
    my $remote = $rr->get_cv('main','authorisation');
    if (($eqid || $authid) && $remote && $remote =~ /remote/i)
    {
	return 1;
    }
    return 0;
}

sub get_id()
##########################################################
### This function returns the user and password as an  ###
### array where the username is the first element and  ###
### the password is the second element                 ###
### usage:  my ($user,$pass) = &get_id;                ###
### Any arguments is passed to get_user and get_pass   ###
##########################################################
{
    my @l = ();
    push @l, &get_user(@_);
    push @l, &get_pass(@_);
    return @l;
}

sub get_users()
{
    my ($u,$p) = &get_id();
    my $res = &passwd_client('get_users',$u,$p);
    if (defined($res))
    {
	chomp $res; 
	return split(/\n+/,$res);
    }
    return undef;
}

sub get_user()
###########################################################
### This function gets the current user                 ###
### Returns undef if the name parameter does not exsis  ###
### if an argument is given, the function first checks  ###
### for a parameter and then for cookies, revers if not ###
###########################################################
{
    return scalar param('name');
}

sub get_pass()
###########################################################
### This function gets the current passwd               ###
### Returns undef if the name parameter does not exsis  ###
### if an argument is given, the function first checks  ###
### for a parameter and then for cookies, revers if not ###
###########################################################
{
    return scalar param('pass');
}

sub action($)
#############################################################
### This function prints a hidden field with hame action ####
### and value equal to the argument                      ####
### Usage  action($value);                               ####
#############################################################
{
    print hidden(-name=>'action',-value=>shift,-force=>'1');
}

sub login
################################################
### This function prints a login table      ####
### The html tags created is:               ####
### name: the username                      ####
### pass: The password                      ####
### action: The name of the submit button   ####
### The value of this is 'Login'            ####
################################################
{
    my $remote_url = get_config_value('passwds','sso_url');
    if ($remote_url)
    {
	my $url = 'http://'.hostname().'/cgi-bin/celletest/main.cgi';
	$url = 'http://'.hostname().'/cgi-bin/celletest/main.cgi' if (CGI::https());
	my $str = encode_base64($url);
	if ($str)
	{
	    $str =~ s/\n//g;
	}
	### Add dummy parameter to awoid stripping end of true link by mail clients etc ###
	$str .= '&end=here';
	my $link = $url.'?dest='.$str;
	print start_form(-name=>'login',-class=>"form",-action=>$url.'?dest='.$str);
	print submit(-name=>'action',-value=>'Login',-class=>'hidden');
	print end_form;
    }
    print "\n",'<script lanuage="javascript">',"\n";
    my $script = 'popup.html';
    if (get_config_value('global','use_passwd') && get_config_value('global','use_passwd') =~ /yes/)
    {
	$script = 'popup_pwd.html';
    }
    print <<END;

    function windowOpen() {
        var myWindow=window.open('../../celltest/$script','windowRef','width=450,height=100,left=300,top=200');
        myWindow.location.href = '../../celltest/$script';
    if (!myWindow.opener)
        myWindow.opener = self;
        myWindow.focus();
    }

    function go()
    {
	document.login.jscheck.value = 1;
        document.login.action.click();
    }

    windowOpen();
//--></script>

END

    print start_form(-name=>'login',-class=>"form",-onsubmit=>'return checkjs()',-action=>'login.cgi');
    print hidden(-name=>'jscheck',-value=>'0',-force=>'1');
    print hidden(-name=>'name',-value=>'',-value=>'1');
    print hidden(-name=>'pass',-value=>'',-value=>'1');
    print submit(-name=>'action',-value=>'Login',-class=>'hidden');
#    print '</th></tr></table>';
    print end_form;
}

sub RFC_start_html
#####################################################################
### This function is a wrapper for start_html but automatically #####
### if the onload argument is already given the logout script   #####
### is just added to the functions which are to be run.         #####
#####################################################################
{
    my %h = @_;
    my $onload = 0;
    for my $key (keys %h)
    {
        if ($key =~ /-onload/i)
        {
            my $str = $h{$key};
            my $e = '';
            if ($str =~ /([\'\"])$/)
            {
                $e = $1;
                $str =~ s/[\'\"]$//;
            }
            $str = $str . ';'.$e;
            $h{$key} = $str;
            $onload = 1;
        }
    }
    $h{'-script'} = { -language => 'javascript', -src => '/celltest/RFCcontrol.js' };
    return CGI::start_html(%h);
}

sub print_header($)
#########################################################
### This function prints the header for the web pages ###
### Any second argument is used as the javascript     ###
### function to be called after the page loads        ###
#########################################################
{
    my $time = &logout_delay();
    $time =~ /(\d+)/;
    $time = $1+0;
    $time = ($time * 60 * 1000) - 10000;
    my $tit = shift;
    my $use_time = 1;
    $use_time = 0 if (get_config_value('global','use_time') && get_config_value('global','use_time') =~ /no/i);
    my $res = header(-charset=>'utf-8');
    my %h = @_;
    my $onload = 0;
    for my $key (keys %h)
    {
        if ($key =~ /-onload/i)
        {
            my $str = $h{$key};
            my $e = '';
            if ($str =~ /([\'\"])$/)
            {
                $e = $1;
                $str =~ s/[\'\"]$//;
            }
            $str = $str . ';doAlertLogout('.$time.');'.$e if ($use_time);
            $h{$key} = $str;
            $onload = 1;
        }
    }
    if ($use_time && !$onload)
    {
        $res .= RFC_start_html(%h,-title=>$tit,-style=>{src=>'/celltest/RFCcontrol7.css'},-onLoad=>'doAlertLogout('.$time.')');
    }
    else
    {
        $res .= RFC_start_html(%h,-title=>$tit,-style=>{src=>'/celltest/RFCcontrol7.css'});
    }
    print $res;
    print "\n\n";
    print start_form(-name=>'login_info');
    print_hidden_rig();
    print hidden(-name=>'time',-value=>0,-force=>1);
    print hidden(-name=>'jscheck',-value=>0,-force=>1);
    my $rig = param('rig');
    if ($rig)
    {
	$rig += 0;
	my $f = $publicdir.'/rig'.$rig.'/test.nr';
	if (-e $f)
	{
	    eval {
		open MYIN,'<',$f or die "Could not open fil $f for reading $!\n";
		my $t = <MYIN>;
		close MYIN;
		$t = 0 unless ($t);
		print hidden(-name=>'testnr',-value=>$t,-force=>1) if ($rig);
	    };
	    if ($@)
	    {
		&errorlog($@);
	    }
	}
	else
	{
	    print hidden(-name=>'testnr',-value=>0,-force=>1);
	}
    }
    print end_form();
    print "\n\n";
}


sub print_end()
{
    print end_html;
}

sub print_end_old()
#######################################
### Prints the end_html command #######
#######################################
{
    my $file = 'manual.pdf';
    $file = shift if (@_);
    print "\n\n";
    print '</div><div class="bottom_div">';
    print '<table border=0 width=60% align=center><tr><th style="text-align:center;">';
    print center(a({-href=>'javascript:load_help();'},'Help'));
    print <<END;

<script lanuage="javascript">
function load_help()
{
    var myWindow=window.open('/celltest/$file','windowRef','width=700,height=500,left=100,top=100,resizable=yes,scrollbars=yes');
    myWindow.location.href = '/celltest/$file';
    if (!myWindow.opener)
    {
        myWindow.opener = self;
        myWindow.focus();
    }
}

</script>

END
    print center(p('Copyright &copy '.$RFC::Header::COPYYEAR.' '.$RFC::Header::IMPLEMENTERS.', '.$RFC::Header::COPYRIGHT));
    print '</th></tr></table></div>';
    print end_html;
}

sub logout
##########################################
###  Function printing a logout button ###
##########################################
{
    my $user = param('user');
    print start_form(-action=>'prelogin.cgi');
    if ($user)
    {
	print submit(-class=>'s0',-name=>'logout',-value=>'Logout '.$user);
    }
    else
    {
	print submit(-class=>'s0',-name=>'logout',-value=>'Logout');
    }
    print end_form;
}


sub not_auth()
{
    print_header("Access to $name denied!");
    print h1({-class=>'C'},"Access to $name denied!");
    if ($msg)
    {
	print h2({-class=>'C'},$msg);
    }
    else
    {
	print h2({-class=>'C'},"Possibly wrong username");
    }
    print '<center>';
    print '<td>';
    print start_form(-class=>"form",-name=>'Return',-action=>'prelogin.cgi');
    print '<table>';
    print '<tr><td width=200>';
    &menu_button("To login page","To login page",'s4');
    print '</td></tr></table>';
    print end_form();
    print '</center>';
    print_end;
}


sub js_back
##############################################
### This function prints a javascript which ##
### takes the browser one step backwards    ##
##############################################
{
    print "\n",'<script>',"\n";
    print 'function back() {',"\n";
    print '  history.back();',"\n";
    print '  return false;',"\n";
    print '}',"\n";
    print '</script>',"\n";
}

sub print_hidden()
#########################################################################
### Prints the logininformation to be transfered to the next cgi call ###
### If called with arguments the username and password is used from   ###
### the passed arguemnts instead from CGI parameters                  ###
#########################################################################
{
    my $user = get_user();
    my $pass = get_pass();
    if (@_)
    {
	$user = shift;
	$pass = shift;
    }
    print hidden(-name=>'name',-value=>$user,-force=>1);
    print hidden(-name=>'pass',-value=>$pass,-force=>1);
}

sub print_hidden_rig()
#########################################################################
### Prints the logininformation to be transfered to the next cgi call ###
### If called with arguments the username and password is used from   ###
### the passed arguemnts instead from CGI parameters                  ###
#########################################################################
{
    &print_hidden(@_);
    print hidden(-name=>'rig');
}


sub top_nav_bar_start
##################################################
###Function creating the top_navigator_bar   #####
###                                          #####
##################################################
{
    print '<div class="main_div">';
    print '<table class=top_table>';
    print '<tr>';
    if (&get_user())
    {
	&top_logout();
    }
    else
    {
	&top_no_button();
    }
    &print_page();
}

sub print_page()
###################################################
### Function creating a top bar button for      ###
### printing the active page                    ###
###################################################
{
    print '<td>';
    print "\n<script lanuage=\"javascript\">\n";
    print "function printWindow() {\n";
    print "   var bV = parseInt(navigator.appVersion);\n";
    print "   if (bV >= 4) {\n";
    print "      window.print();\n";
    print "   }\n";
    print "}\n";
    print "</script>\n";
    print start_form(-name=>'dummy',-class=>'form');
    print button(-name=>'Printpage',-value=>'Print page',-class=>'print',-onclick=>'printWindow()');
    print end_form;
    print '</td>';
}


sub top_nav_bar_button($$@)
#######################################################################
### Prints a nav bar button which when pressed                     ####
### takes the user to the $file CGI-script and                     ####
### parses the action parameter $action to the                     ####
### script. For the 3 last arguments, see                          ####
### menu_button()                                                  ####
### Usage top_nav_bar_button($file,$action,$1,$2,$3,[opt args])    ####
### Arguments 1 to 3 are parced directly to                        ####
### menu_button().                                                 ####
### It is possible to specify parameters to be printed in hidden   ####
### fields by adding additional arguments, each additional         ####
### argument must be a comma separated list specifying (in order!) ####
### name, value and force (0/1). if the parameter is just to be    ####
### 'sticky, let the last two elements be blank, eks: search_val,, ####
### would print a hidden field with name 'search_val' and the      ####
### value would be whatever the previous field with name           ####
### 'searh_val' had.                                               ####
#######################################################################
{
    my $file = shift;
    my $action = shift;
    print '<td>';
    if ($file)
    {
        print start_form(-action=>$file,-class=>"form");
    }
    else
    {
        print start_form(-class=>"form");
    }
    &action($action) if ($action);
    my @args = ();
    push @args, shift @_;
    push @args, shift @_;
    push @args, shift @_;
    &menu_button(@args);
    &print_hidden();
    while (@_)
    {
        my @s = split(/\s*\,\s*/,shift @_);
        print hidden(-name=>$s[0],-value=>$s[1],-force=>$s[2]);
    }
    print end_form();
    print "</td>\n";
}



sub top_no_button
#################################
### Prints a 'empty' button   ###
### in the top nav bar        ###
#################################
{
    print '<td>';
    start_form;
    &menu_button('','','none');
    end_form;
    print "</td>\n";
}

sub top_js_return
#############################################################
### Prints a return button  in the top navbar which uses  ###
### javascript to bring the user one step back            ###
### Note that the function requires that the function     ###
### &js_back() is used somewhere on the page!!!           ###
#############################################################
{
    print '<td>';
    print start_form(-class=>"form",-onsubmit=>"return back()");
    &print_hidden();
    &menu_button('Back','Back','back');
    print end_form();
    print "</td>\n";
}
sub top_logout
#############################################################
### Prints a logout button  in the top navbar which uses  ###
### javascript to ask if the user wants to logout         ###
#############################################################
{
    my $name = get_user();
    my $pass = get_pass();
    my $scr = '/cgi-bin/celltest/ajax.cgi';
    print "\n\n<script lanuage=\"javascript\">\n";
    print "IsLoggedIn = 1;\n\n";
    print "function LogOut() {\n";
    print "   if (IsLoggedIn == 0) {\n";
    print "       raw_ajax('$scr','?action=logout&name=$name&pass=$pass',doLogOut);\n";
    print "       return true;\n";
    print "   }\n";
    print "   if (confirm('Do you want to log out?')) {\n";
    print "       raw_ajax('$scr','?action=logout&name=$name&pass=$pass',doLogOut);\n";
    print "       return true;\n";
    print "   }\n";
    print "   return false;\n";
    print "}\n";
    print "function doLogOut(res) {\n";
    print "   if (IsLoggedIn == 1) {\n";
    print "       alert(res);\n";
    print "   }\n";
    print "   document.logout.submit();\n";
    print "   return true;\n";
    print "}\n";
    print "</script>\n\n";
    my $user = &get_user();
    print '<td>';

    my $remote_url = get_cv('passwds','sso_logout_url');
    if ($remote_url)
    {
	print start_form(-class=>"form",-name=>'logout',-action=>$remote_url);
    }
    else
    {
	print start_form(-class=>"form",-name=>'logout',-action=>'prelogin.cgi');
    }
    print hidden(-name=>'dummy',-value=>0,-force=>1);
    if ($user)
    {
	print button(-name=>'Logout',-value=>'Logout '.$user,-class=>'s0',-onclick=>"return LogOut()");
    }
    else
    {
	print button(-name=>'Logout',-value=>'Logout',-class=>'s0',-onclick=>"return LogOut()");
    }
    print end_form();
    print '</td>';
}


sub tab_newrow
################################
### prints a html collumn    ###
### separator                ###
################################
{
    print '</tr><tr>';
}

sub end_top_bar
#################################
### Ends the top nav bar     ####
#################################
{
    print '</tr>';
    print '</table>';
}


sub menu_button($$$)
##################################################################
### This funtion creates a menu button                         ###
### Usage: menu_button($bgcolor,$color,$value,$name);          ###
##################################################################
{
    my $name = shift;
    my $value = shift;
    my $style = shift;
    print submit(-name=>$name,-class=>$style,-value=>$value);
}

sub clean($)
###########################################################
#### This function cleans a string for all special      ###
#### characters (only allowed ones are '-','.' and ',') ###
###########################################################
{
    my $val = shift;
    my $ret = undef;
    if (defined($val) && $val =~ /([\w\s\.\,\-]*)/)
    {
        $ret = $1;
    }
    return $ret;
}

sub get_CGI_value_clean($)
##################################################
#### Wrapper for &clean and &get_CGI_value    ####
##################################################
{
    my $id = shift;
    my $val = &get_CGI_value($id);
    return &clean($val);
}

sub get_CGI_value($)
####################################################
#### This function gets the CGI parameter with   ###
#### $name, returns undef if the parameter is    ###
#### not defined in the input parameters         ###
#### Usage: get_CGI_value($name)                 ###
####################################################
{
    my $id = $_[0];
    my $val = undef;
    $val = param($id) if defined(param($id));
    return $val;
}


sub get_config_value(@)
{
    return &RFC::Main::get_cv(@_);
}

sub passwd_client(@)
{
    return RFC::Main::passwd_client(@_);
}

sub get_logout_time()
#########################################################
### Returns the maximum time before automatic logout ####
#########################################################
{
    my $logoutdelay = &RFC::Main::get_cv('global','logoutdelay');
    my $time = &time_string(&get_time($logoutdelay));
    return $time;
}


sub get_time($)
##########################################################################
### Function which returns the time in format YYYY MM DD HH MM SS      ###
### Output is in the form of an array                                  ###
### Input is either 'now' or the offset (check 'man date' for details) ###
##########################################################################
{
    my $t = shift;
    my $date_format = " +\"%Y:%m:%d:%H:%M:%S\"";
    my $date = "--date=\"$t\"";
    my $time_format = "$date_format $date\n";
    my $time = `/bin/date $time_format`;
    my @t = split(/:/,$time);
    return @t;
}

sub time_string(@)
##################################################################
### Function which returns a string with the concatanated date ###
### information. Places leading 0'es where nescesary           ###
##################################################################
{
    my $time ="";
    my @t;
    my @l = @_;
    foreach (@l)
    {
	if ($_ < 10)
	{
	    $_ = '0'.$_ unless (/0\d/);
	}
    }
    return join('',@l);
}

sub print_js_validate
###############################################################
### This function prints a javascript for input validation  ###
### The function can check any number of fields (names      ###
### specified in the arguments list) and can either check   ###
### if a field is filled out, OR check that if a field      ###
### value is 'NEW' then an other field must not be empty    ###
### The syntax for this case is: 'name_1#name_2' where      ###
### name_1 is the name of the field which can be 'NEW' and  ###
### name_2 is the name of field 2 which must not be empty.  ###
### Another form of check is where a number of fields       ###
### exists and where not all fields can be empty            ###
### to use this option use the ':' separator in the string: ###
###   '$field_group_name:$field1:$field2:...'               ###
### Usage:  print_js_validate($form_name,[$field_names...]) ###
### It is also possible to include regular expression tests ###
### in the validation. To do this use the format:           ###
### 'name;"regexp";[opt $]Error message'. If the $ is       ###
### the value of the input field is placed in front of the  ###
### errormessage!                                           ###
###############################################################
{
    my $name = shift;
    ### If the name argument begins with a '#' then the initial  ###
    ### part f the function has already been added (likely       ###
    ### py print_js_validate_modify() ) and is ignored and the   ###
    ### '#' in the name is removed                               ###
    if ($name =~ /\#(\w+)/)
    {
        $name = $1;
    }
    else
    {
        print "\n\n";
        print '<script>',"\n";
        print 'function checkinput() {',"\n";
        print '  var f = document.',$name,";\n";
    }
    print "  var txt = '';\n";
    print "  var newf = '';\n";
    while (scalar(@_) > 0)
    {
        my $s = shift;
        if ($s =~ /^\w+$/)
        {
            ############ Print an normal field check ########
            print '  txt = f.'.$s.'.value;',"\n";
            print '  if (txt == null || txt.length == 0) {',"\n";
            print '     alert("Required field \"'.$s.'\" has not been input!");',"\n";
            print '     return false;',"\n";
            print "  }\n";
        }
        if ($s =~ /^(\w+)\;\"(.*)\"\;([\$\w\s\,\\\-\+]+)$/)
        {
            my $name = $1;
            my $regexp = $2;
            my $text = $3;
            ############ Print an normal field check with regexp ########
            print '  txt = f.'.$name.'.value;',"\n";
            print '  if (txt == null || txt.length == 0) {',"\n";
            print '     alert("Required field \"'.$name.'\" has not been input!");',"\n";
            print '     return false;',"\n";
            print "  }\n";
            print '  reg = /'.$regexp."/;\n";
            print '  if (!reg.test(txt)) {',"\n";
            if ($text =~ /\$/)
            {
                $text =~ s/\$//g;
                print '     alert(txt+"'.$text.'");',"\n";
            }
            else
            {
                print '     alert("'.$text.'");',"\n";
            }
            print '     return false;',"\n";
            print '  }',"\n";
        }
        if ($s =~ /^(\w+)\#(\w+)$/)
        {
            ############ Prints a composite field check (NEW check) #######
            print '  txt = f.'.$1.'.value;',"\n";
            print '  if (txt == null || txt.length == 0) {',"\n";
            print '     alert("Required field \"'.$1.'\" has not been input!");',"\n";
            print '     return false;',"\n";
            print "  }\n";
            print '  newf = f.'.$2.'.value;',"\n";
            print '  if (txt == "NEW" && (newf == null || newf.length == 0)) {',"\n";
            print '     alert("When using \"NEW\" in drop-down box \"'.$1.'\" new field must not be empty!");',"\n";
            print '     return false;',"\n";
            print "  }\n";
        }
        if ($s =~ /^(\w+)\=(\w+)/)
        {
           ############ Prints a composite field check (yes check) #######
            print '  txt = document.'.$name.'.'.$1.'.value;',"\n";
            print '  newf = f.'.$2.'.value;',"\n";
            print '  if (txt == "Yes" && (newf == null || newf.length == 0)) {',"\n";
            print '     alert("When using \"Yes\" in drop-down box \"'.$1.'\" field \"'.$2.'\" must not be empty!");',"\n";
            print '     return false;',"\n";
            print "  }\n";
            if ($s =~ /\=\w+\;\"(.*)\"\;([\$\w\s\,\\\-\+]+)$/)
            {
                print '  else {',"\n";
                print '     if (txt == "Yes" ) {',"\n";
                my $regexp = $1;
                my $text = $2;
                ############ Print regexp check of last field ########
                print '        reg = /'.$regexp."/;\n";
                print '        if (!reg.test(newf)) {',"\n";
                if ($text =~ /\$/)
                {
                    $text =~ s/\$//g;
                    print '           alert(newf+"'.$text.'");',"\n";
                }
                else
                {
                    print '           alert("'.$text.'");',"\n";
                }
                print '           return false;',"\n";
                print '        }',"\n";
                print '     }',"\n";
                print "  }\n";
            }
        }
        if ($s =~ /^([\w\s]+)\:([\w\:]+)/)
        {
            #######  Prints a multi field input check where just one  ####
            #######  field input is enough for true                   ####
            my $n = $1;
            my $t = $2;
            my @l = split(/\:/,$t);
            print '  var ok = 0;',"\n";
            for (my $x = 0; $x < @l; $x++)
            {
                print '  txt = f.'.$l[$x].'.value;',"\n";
                print '  if (txt != null && txt.length != 0) {',"\n";
                print '     ok = 1;',"\n";
                print '  }',"\n";
            }
            print '  if (ok == 0) {',"\n";
            print '     alert("One of the \"'.$n.'\" fields must be filled in!");',"\n";
            print '     return false;',"\n";
            print "  }\n";
        }
        if ($s =~ /^([\w\.\-\\\s]+)\,([\w\s\;\"\$\^\\\.\,\*\+]+)/)
        {
           #######  Prints a multi field input check where all  ####
            #######  fields must input for true if one is input  ####
            my $n = $1;
            my $t = $2;
            my @l = split(/\,/,$t);
            print '  var ok = 0;',"\n";
            for (my $x = 0; $x < @l; $x++)
            {
                $l[$x] =~ /^(\w+)/;
                my $st = $1;
                print '  txt = f.'.$st.'.value;',"\n";
                print '  if (txt != null && txt.length != 0) {',"\n";
                print '     ok = 1;',"\n";
                print '  }',"\n";
            }
            print '  if (ok == 1) {',"\n";
            for (my $x = 0; $x < @l; $x++)
            {
                $l[$x] =~ /^(\w+)/;
                my $st = $1;
                print '     txt = f.'.$st.'.value;',"\n";
                print '     if (txt == null || txt.length == 0) {',"\n";
                print '        alert("All of the ',$n,' fields must be filled in if one value is given")',"\n";
                print '        return false;',"\n";
                print '     }',"\n";
                ##### Add regexp check if nescesarry #####
                if ($l[$x] =~ /\;\"([\w\$\^\\\.\+\*]+)\"\;([\$\.\w\s]*)/)
                {
                    my $regexp = $1;
                    my $text = $2;
                    print '     reg = /'.$regexp."/;\n";
                    print '     if (!reg.test(txt)) {',"\n";
                    if ($text =~ /\$/)
                    {
                        $text =~ s/\$//g;
                        print '        alert(txt+"'.$text.'");',"\n";
                    }
                    else
                    {
                        print '        alert("'.$text.'");',"\n";
                    }
                    print '        return false;',"\n";
                    print '     }',"\n";
                }
            }
            print "  }\n";
        }
    }
    print "  return true;\n";
    print "}\n";
    print '</script>';
    print "\n\n";
}

