strepsirrhini/office-gobmx
9
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
office-gobmx/solenv/bin/modules/CwsConfig.pm
Jens-Heiner Rechtien 8312baf424 INTEGRATION: CWS ause056 (1.8.80); FILE MERGED 
2006/06/07 14:06:27 hr 1.8.80.2: #i66155#: improve quoting check
2006/06/07 12:54:18 hr 1.8.80.1: #i66155#: allow quoting of value strings
2006-06-09 11:16:22 +00:00

432 lines
12 KiB
Perl
Raw Blame History

#*************************************************************************
#
# OpenOffice.org - a multi-platform office productivity suite
#
# $RCSfile: CwsConfig.pm,v $
#
# $Revision: 1.9 $
#
# last change: $Author: hr $ $Date: 2006-06-09 12:16:22 $
#
# The Contents of this file are made available subject to
# the terms of GNU Lesser General Public License Version 2.1.
#
#
# GNU Lesser General Public License Version 2.1
# =============================================
# Copyright 2005 by Sun Microsystems, Inc.
# 901 San Antonio Road, Palo Alto, CA 94303, USA
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License version 2.1, as published by the Free Software Foundation.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
#
#*************************************************************************
#
# CwsConfig.pm - package for read CWS config data
#
package CwsConfig;
use strict;
use Carp;
use URI::Escape;
##### ctor ####
sub new
{
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {};
$self->{_CONFIG_FILE} = undef; # config file
$self->{_GLOBAL} = undef; # is it a global config file?
$self->{VCSID} = undef; # VCSID
$self->{CWS_DB_URL_LIST_REF} = undef; # list of CWS DB servers
$self->{NET_PROXY} = undef; # network proxy
$self->{CWS_SERVER_ROOT} = undef; # cvs server
$self->{CWS_MIRROR_ROOT} = undef; # mirror of cvs server
$self->{CWS_LOCAL_ROOT} = undef; # local cvs server
bless ($self, $class);
return $self;
}
sub vcsid
{
my $self = shift;
if ( !defined($self->{VCSID}) ) {
# environment overrides config file
my $vcsid = $ENV{VCSID};
if ( !defined($vcsid) ) {
# check config file
my $config_file = $self->get_config_file();
$vcsid = $config_file->{CWS_CONFIG}->{'CVS_ID'};
if ( !defined($vcsid) ) {
# give up
croak("ERROR: no CVS_ID entry found in '\$HOME/.cwsrc'.\n" );
}
}
$self->{VCSID} = $vcsid;
}
return $self->{VCSID};
}
sub cws_db_url_list_ref
{
my $self = shift;
if ( !defined($self->{CWS_DB_URL_LIST_REF}) ) {
my $config_file = $self->get_config_file();
my $i = 1;
my @cws_db_servers;
while ( 1 ) {
my $val = $config_file->{CWS_CONFIG}->{"CWS_DB_SERVER_$i"};
last if !defined($val);
push(@cws_db_servers, $val);
$i++;
}
if ( !@cws_db_servers) {
croak("ERROR: no CWS_DB_SERVER_* entry found in '\$HOME/.cwsrc'.\n" );
}
if ( $cws_db_servers[0] =~ /^https:\/\// ) {
my $id = $self->vcsid();
my $password = $config_file->{CWS_CONFIG}->{'CVS_PASSWORD'};
if ( !defined($password) ) {
croak("ERROR: no CVS_PASSWORD entry found in '\$HOME/.cwsrc'.\n" );
}
# *i49473* - do not accept scrambled passwords ending with a space
if ( $password =~ / $/) {
croak("ERROR: The (scrambled) CVS_PASSWORD ends with a space. This is known to cause problems when connecting to the OpenOffice.org EIS database. Please change your OOo account's password" );
}
# We are going to stuff $id and $password in an URL, do proper escaping.
$id = uri_escape($id);
$password = uri_escape($password);
foreach ( @cws_db_servers ) {
s/^https:\/\//https:\/\/$id:$password@/;
}
}
$self->{CWS_DB_URL_LIST_REF} = \@cws_db_servers;
}
return $self->{CWS_DB_URL_LIST_REF};
}
sub net_proxy
{
my $self = shift;
if ( !defined($self->{NET_PROXY}) ) {
my $config_file = $self->get_config_file();
my $net_proxy = $config_file->{CWS_CONFIG}->{'PROXY'};
if ( !defined($net_proxy) ) {
$net_proxy = "";
}
$self->{NET_PROXY} = $net_proxy;
}
return $self->{NET_PROXY} ? $self->{NET_PROXY} : undef;
}
sub cvs_binary
{
my $self = shift;
if ( !defined($self->{CVS_BINARY}) ) {
my $config_file = $self->get_config_file();
my $cvs_binary = $config_file->{CWS_CONFIG}->{'CVS_BINARY'};
if ( !defined($cvs_binary) ) {
# defaults
$cvs_binary = ($^O eq 'MSWin32') ? 'cvs.exe' : 'cvs';
}
# special case, don't ask
if ( $self->{_GLOBAL} && $cvs_binary =~ /cvs.clt2/ && $^O eq 'MSWin32' ) {
$cvs_binary = 'cvsclt2.exe';
}
$self->{CVS_BINARY} = $cvs_binary;
}
return $self->{CVS_BINARY};
}
sub cvs_server_root
{
my $self = shift;
if ( !defined($self->{CVS_SERVER_ROOT}) ) {
my $config_file = $self->get_config_file();
my $cvs_server_root = $config_file->{CWS_CONFIG}->{'CVS_SERVER_ROOT'};
if ( !defined($cvs_server_root) ) {
# give up, this is a mandatory entry
croak("ERROR: can't parse CVS_SERVER_ROOT entry in '\$HOME/.cwsrc'.\n");
}
if ( $self->{_GLOBAL} ) {
# a global config file will almost always have the wrong vcsid in
# the cvsroot -> substitute vcsid
my $id = $self->vcsid();
$cvs_server_root =~ s/:pserver:\w+@/:pserver:$id@/;
}
$self->{CVS_SERVER_ROOT} = $cvs_server_root;
}
return $self->{CVS_SERVER_ROOT};
}
sub cvs_mirror_root
{
my $self = shift;
if ( !defined($self->{CVS_MIRROR_ROOT}) ) {
my $config_file = $self->get_config_file();
my $cvs_mirror_root = $config_file->{CWS_CONFIG}->{'CVS_MIRROR_ROOT'};
if ( !defined($cvs_mirror_root) ) {
$cvs_mirror_root = "";
}
$self->{CVS_MIRROR_ROOT} = $cvs_mirror_root;
}
return $self->{CVS_MIRROR_ROOT} ? $self->{CVS_MIRROR_ROOT} : undef;
}
sub cvs_local_root
{
my $self = shift;
if ( !defined($self->{CVS_LOCAL_ROOT}) ) {
my $config_file = $self->get_config_file();
my $cvs_local_root = $config_file->{CWS_CONFIG}->{'CVS_LOCAL_ROOT'};
if ( !defined($cvs_local_root) ) {
$cvs_local_root = "";
}
$self->{CVS_LOCAL_ROOT} = $cvs_local_root;
}
return $self->{CVS_LOCAL_ROOT} ? $self->{CVS_LOCAL_ROOT} : undef;
}
sub get_cvs_server
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER');
return $server;
}
sub get_cvs_mirror
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR');
return $server;
}
sub get_cvs_local
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL');
return $server;
}
sub get_cvs_server_method
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER');
return $method;
}
sub get_cvs_mirror_method
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR');
return $method;
}
sub get_cvs_local_method
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL');
return $method;
}
sub get_cvs_server_repository
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER');
return $repository;
}
sub get_cvs_mirror_repository
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR');
return $repository;
}
sub get_cvs_local_repository
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL');
return $repository;
}
sub get_cvs_server_id
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER');
return $id;
}
sub get_cvs_mirror_id
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR');
return $id;
}
sub get_cvs_local_id
{
my $self = shift;
my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL');
return $id;
}
#### class methods #####
sub get_config
{
my $config = CwsConfig->new();
return $config;
}
sub split_root
{
my $root = shift;
my $type = shift;
if ( !defined($root) ) {
return (undef, undef, undef, undef);
}
my ($dummy, $method, $id_at_host, $repository) = split(/:/, $root);
$repository =~ s/^\d*//;
my ($id, $server);
if ( $id_at_host ) {
($id, $server) = split(/@/, $id_at_host);
}
if ( !defined($method) || !defined($id) || !defined($server) || !defined($repository) ) {
# give up
print "$method, $id, $server, $repository\n";
croak("ERROR: can't parse CVS_".$type."_ROOT entry in '\$HOME/.cwsrc'.\n");
}
return ($method, $id, $server, $repository);
}
#### private helper methods ####
sub get_config_file
{
my $self = shift;
if ( !defined $self->{_CONFIG_FILE} ) {
$self->parse_config_file();
}
return $self->{_CONFIG_FILE};
}
sub read_config
{
my $self = shift;
my $fname = shift;
my $fhandle;
my $section = '';
my %config;
open ($fhandle, $fname) || croak("ERROR: Can't open '$fname': $!");
while ( <$fhandle> ) {
tr/\r\n//d; # win32 pain
# Issue #i62815#: Scrambled CVS passwords may contain one or more '#'.
# Ugly special case needed: still allow in-line (perl style) comments
# elsewhere because existing configuration files may depend on them.
if ( !/^\s*CVS_PASSWORD/ ) {
s/\#.*//; # kill comments
}
/^\s*$/ && next;
if (/\[\s*(\S+)\s*\]/) {
$section = $1;
if (!defined $config{$section}) {
$config{$section} = {};
}
}
defined $config{$section} || croak("ERROR: unknown / no section '$section'\n");
if ( m/(\w[\w\d]*)=(.*)/ ) {
my $var = $1;
my $val = $2;
# New style value strings may be surrounded by quotes
if ( $val =~ s/\s*(['"])(.*)\1\s*$/$2/ ) {
my $quote = $1;
# If and only if the value string is surrounded by quotes we
# can expect that \" or \' are escaped characters. In an unquoted
# old style value string they could mean exactly what is standing there
#
# Actually the RE above works without quoting the quote character
# (either " or ') inside the value string but users will probably
# expect that they need to be escaped if quotes are used.
#
# This is still not completly correct for all thinkable situations but
# should be good enough for all practical use cases.
$val =~ s/\\($quote)/$1/g;
}
$config{$section}->{$var} = $val;
# print "Set '$var' to '$val'\n";
}
}
close ($fhandle) || croak("ERROR: Failed to close: $!");
$self->{_CONFIG_FILE} = \%config;
}
sub parse_config_file
{
my $self = shift;
my $config_file;
# check for config files
if ( -e "$ENV{HOME}/.cwsrc" ) {
$self->read_config("$ENV{HOME}/.cwsrc");
$self->{_GLOBAL} = 0;
}
elsif ( -e "$ENV{COMMON_ENV_TOOLS}/cwsrc" ) {
$self->read_config("$ENV{COMMON_ENV_TOOLS}/cwsrc");
$self->{_GLOBAL} = 1;
}
else {
croak("ERROR: can't find CWS config file '\$HOME/.cwsrc'.\n");
}
}
1; # needed by "use" or "require"
Reference in a new issue View git blame Copy permalink