1*cdf0e10cSrcweir#************************************************************************* 2*cdf0e10cSrcweir# 3*cdf0e10cSrcweir# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. 4*cdf0e10cSrcweir# 5*cdf0e10cSrcweir# Copyright 2000, 2010 Oracle and/or its affiliates. 6*cdf0e10cSrcweir# 7*cdf0e10cSrcweir# OpenOffice.org - a multi-platform office productivity suite 8*cdf0e10cSrcweir# 9*cdf0e10cSrcweir# This file is part of OpenOffice.org. 10*cdf0e10cSrcweir# 11*cdf0e10cSrcweir# OpenOffice.org is free software: you can redistribute it and/or modify 12*cdf0e10cSrcweir# it under the terms of the GNU Lesser General Public License version 3 13*cdf0e10cSrcweir# only, as published by the Free Software Foundation. 14*cdf0e10cSrcweir# 15*cdf0e10cSrcweir# OpenOffice.org is distributed in the hope that it will be useful, 16*cdf0e10cSrcweir# but WITHOUT ANY WARRANTY; without even the implied warranty of 17*cdf0e10cSrcweir# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18*cdf0e10cSrcweir# GNU Lesser General Public License version 3 for more details 19*cdf0e10cSrcweir# (a copy is included in the LICENSE file that accompanied this code). 20*cdf0e10cSrcweir# 21*cdf0e10cSrcweir# You should have received a copy of the GNU Lesser General Public License 22*cdf0e10cSrcweir# version 3 along with OpenOffice.org. If not, see 23*cdf0e10cSrcweir# <http://www.openoffice.org/license.html> 24*cdf0e10cSrcweir# for a copy of the LGPLv3 License. 25*cdf0e10cSrcweir# 26*cdf0e10cSrcweir#************************************************************************* 27*cdf0e10cSrcweir 28*cdf0e10cSrcweir 29*cdf0e10cSrcweir# 30*cdf0e10cSrcweir# CwsConfig.pm - package for read CWS config data 31*cdf0e10cSrcweir# 32*cdf0e10cSrcweir 33*cdf0e10cSrcweirpackage CwsConfig; 34*cdf0e10cSrcweiruse strict; 35*cdf0e10cSrcweir 36*cdf0e10cSrcweiruse Carp; 37*cdf0e10cSrcweiruse URI::Escape; 38*cdf0e10cSrcweir 39*cdf0e10cSrcweir##### ctor #### 40*cdf0e10cSrcweir 41*cdf0e10cSrcweirsub new 42*cdf0e10cSrcweir{ 43*cdf0e10cSrcweir my $invocant = shift; 44*cdf0e10cSrcweir my $class = ref($invocant) || $invocant; 45*cdf0e10cSrcweir my $self = {}; 46*cdf0e10cSrcweir $self->{_CONFIG_FILE} = undef; # config file 47*cdf0e10cSrcweir $self->{_GLOBAL} = undef; # is it a global config file? 48*cdf0e10cSrcweir $self->{VCSID} = undef; # VCSID 49*cdf0e10cSrcweir $self->{CWS_DB_URL_LIST_REF} = undef; # list of CWS DB servers 50*cdf0e10cSrcweir $self->{NET_PROXY} = undef; # network proxy 51*cdf0e10cSrcweir $self->{CWS_SERVER_ROOT} = undef; # cvs server 52*cdf0e10cSrcweir $self->{CWS_MIRROR_ROOT} = undef; # mirror of cvs server 53*cdf0e10cSrcweir $self->{CWS_LOCAL_ROOT} = undef; # local cvs server 54*cdf0e10cSrcweir $self->{PUBLIC_SVN_SERVER} = undef; # public svn server 55*cdf0e10cSrcweir $self->{PRIVATE_SVN_SERVER} = undef; # private svn server 56*cdf0e10cSrcweir bless ($self, $class); 57*cdf0e10cSrcweir return $self; 58*cdf0e10cSrcweir} 59*cdf0e10cSrcweir 60*cdf0e10cSrcweirsub vcsid 61*cdf0e10cSrcweir{ 62*cdf0e10cSrcweir my $self = shift; 63*cdf0e10cSrcweir 64*cdf0e10cSrcweir if ( !defined($self->{VCSID}) ) { 65*cdf0e10cSrcweir # environment overrides config file 66*cdf0e10cSrcweir my $vcsid = $ENV{VCSID}; 67*cdf0e10cSrcweir if ( !defined($vcsid) ) { 68*cdf0e10cSrcweir # check config file 69*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 70*cdf0e10cSrcweir $vcsid = $config_file->{CWS_CONFIG}->{'CVS_ID'}; 71*cdf0e10cSrcweir if ( !defined($vcsid) ) { 72*cdf0e10cSrcweir # give up 73*cdf0e10cSrcweir croak("ERROR: no CVS_ID entry found in '\$HOME/.cwsrc'.\n" ); 74*cdf0e10cSrcweir } 75*cdf0e10cSrcweir } 76*cdf0e10cSrcweir $self->{VCSID} = $vcsid; 77*cdf0e10cSrcweir } 78*cdf0e10cSrcweir return $self->{VCSID}; 79*cdf0e10cSrcweir} 80*cdf0e10cSrcweir 81*cdf0e10cSrcweirsub cws_db_url_list_ref 82*cdf0e10cSrcweir{ 83*cdf0e10cSrcweir my $self = shift; 84*cdf0e10cSrcweir 85*cdf0e10cSrcweir if ( !defined($self->{CWS_DB_URL_LIST_REF}) ) { 86*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 87*cdf0e10cSrcweir 88*cdf0e10cSrcweir my $i = 1; 89*cdf0e10cSrcweir my @cws_db_servers; 90*cdf0e10cSrcweir 91*cdf0e10cSrcweir while ( 1 ) { 92*cdf0e10cSrcweir my $val = $config_file->{CWS_CONFIG}->{"CWS_DB_SERVER_$i"}; 93*cdf0e10cSrcweir last if !defined($val); 94*cdf0e10cSrcweir push(@cws_db_servers, $val); 95*cdf0e10cSrcweir $i++; 96*cdf0e10cSrcweir } 97*cdf0e10cSrcweir 98*cdf0e10cSrcweir if ( !@cws_db_servers) { 99*cdf0e10cSrcweir croak("ERROR: no CWS_DB_SERVER_* entry found in '\$HOME/.cwsrc'.\n" ); 100*cdf0e10cSrcweir } 101*cdf0e10cSrcweir 102*cdf0e10cSrcweir if ( $cws_db_servers[0] =~ /^https:\/\// ) { 103*cdf0e10cSrcweir my $id = $self->vcsid(); 104*cdf0e10cSrcweir my $password = $config_file->{CWS_CONFIG}->{'CVS_PASSWORD'}; 105*cdf0e10cSrcweir 106*cdf0e10cSrcweir if ( !defined($password) ) { 107*cdf0e10cSrcweir croak("ERROR: no CVS_PASSWORD entry found in '\$HOME/.cwsrc'.\n" ); 108*cdf0e10cSrcweir } 109*cdf0e10cSrcweir 110*cdf0e10cSrcweir # *i49473* - do not accept scrambled passwords ending with a space 111*cdf0e10cSrcweir if ( $password =~ / $/) { 112*cdf0e10cSrcweir 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" ); 113*cdf0e10cSrcweir } 114*cdf0e10cSrcweir 115*cdf0e10cSrcweir # We are going to stuff $id and $password in an URL, do proper escaping. 116*cdf0e10cSrcweir $id = uri_escape($id); 117*cdf0e10cSrcweir $password = uri_escape($password); 118*cdf0e10cSrcweir 119*cdf0e10cSrcweir foreach ( @cws_db_servers ) { 120*cdf0e10cSrcweir s/^https:\/\//https:\/\/$id:$password@/; 121*cdf0e10cSrcweir } 122*cdf0e10cSrcweir } 123*cdf0e10cSrcweir 124*cdf0e10cSrcweir $self->{CWS_DB_URL_LIST_REF} = \@cws_db_servers; 125*cdf0e10cSrcweir } 126*cdf0e10cSrcweir return $self->{CWS_DB_URL_LIST_REF}; 127*cdf0e10cSrcweir} 128*cdf0e10cSrcweir 129*cdf0e10cSrcweirsub net_proxy 130*cdf0e10cSrcweir{ 131*cdf0e10cSrcweir my $self = shift; 132*cdf0e10cSrcweir 133*cdf0e10cSrcweir if ( !defined($self->{NET_PROXY}) ) { 134*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 135*cdf0e10cSrcweir my $net_proxy = $config_file->{CWS_CONFIG}->{'PROXY'}; 136*cdf0e10cSrcweir if ( !defined($net_proxy) ) { 137*cdf0e10cSrcweir $net_proxy = ""; 138*cdf0e10cSrcweir } 139*cdf0e10cSrcweir $self->{NET_PROXY} = $net_proxy; 140*cdf0e10cSrcweir } 141*cdf0e10cSrcweir return $self->{NET_PROXY} ? $self->{NET_PROXY} : undef; 142*cdf0e10cSrcweir} 143*cdf0e10cSrcweir 144*cdf0e10cSrcweirsub cvs_binary 145*cdf0e10cSrcweir{ 146*cdf0e10cSrcweir my $self = shift; 147*cdf0e10cSrcweir 148*cdf0e10cSrcweir if ( !defined($self->{CVS_BINARY}) ) { 149*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 150*cdf0e10cSrcweir my $cvs_binary = $config_file->{CWS_CONFIG}->{'CVS_BINARY'}; 151*cdf0e10cSrcweir if ( !defined($cvs_binary) ) { 152*cdf0e10cSrcweir # defaults 153*cdf0e10cSrcweir $cvs_binary = ($^O eq 'MSWin32') ? 'cvs.exe' : 'cvs'; 154*cdf0e10cSrcweir } 155*cdf0e10cSrcweir # special case, don't ask 156*cdf0e10cSrcweir if ( $self->{_GLOBAL} && $cvs_binary =~ /cvs.clt2/ && $^O eq 'MSWin32' ) { 157*cdf0e10cSrcweir $cvs_binary = 'cvsclt2.exe'; 158*cdf0e10cSrcweir } 159*cdf0e10cSrcweir $self->{CVS_BINARY} = $cvs_binary; 160*cdf0e10cSrcweir } 161*cdf0e10cSrcweir return $self->{CVS_BINARY}; 162*cdf0e10cSrcweir} 163*cdf0e10cSrcweir 164*cdf0e10cSrcweirsub cvs_server_root 165*cdf0e10cSrcweir{ 166*cdf0e10cSrcweir my $self = shift; 167*cdf0e10cSrcweir 168*cdf0e10cSrcweir if ( !defined($self->{CVS_SERVER_ROOT}) ) { 169*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 170*cdf0e10cSrcweir my $cvs_server_root = $config_file->{CWS_CONFIG}->{'CVS_SERVER_ROOT'}; 171*cdf0e10cSrcweir if ( !defined($cvs_server_root) ) { 172*cdf0e10cSrcweir # give up, this is a mandatory entry 173*cdf0e10cSrcweir croak("ERROR: can't parse CVS_SERVER_ROOT entry in '\$HOME/.cwsrc'.\n"); 174*cdf0e10cSrcweir } 175*cdf0e10cSrcweir if ( $self->{_GLOBAL} ) { 176*cdf0e10cSrcweir # a global config file will almost always have the wrong vcsid in 177*cdf0e10cSrcweir # the cvsroot -> substitute vcsid 178*cdf0e10cSrcweir my $id = $self->vcsid(); 179*cdf0e10cSrcweir $cvs_server_root =~ s/:pserver:\w+@/:pserver:$id@/; 180*cdf0e10cSrcweir } 181*cdf0e10cSrcweir $self->{CVS_SERVER_ROOT} = $cvs_server_root; 182*cdf0e10cSrcweir } 183*cdf0e10cSrcweir return $self->{CVS_SERVER_ROOT}; 184*cdf0e10cSrcweir} 185*cdf0e10cSrcweir 186*cdf0e10cSrcweirsub cvs_mirror_root 187*cdf0e10cSrcweir{ 188*cdf0e10cSrcweir my $self = shift; 189*cdf0e10cSrcweir 190*cdf0e10cSrcweir if ( !defined($self->{CVS_MIRROR_ROOT}) ) { 191*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 192*cdf0e10cSrcweir my $cvs_mirror_root = $config_file->{CWS_CONFIG}->{'CVS_MIRROR_ROOT'}; 193*cdf0e10cSrcweir if ( !defined($cvs_mirror_root) ) { 194*cdf0e10cSrcweir $cvs_mirror_root = ""; 195*cdf0e10cSrcweir } 196*cdf0e10cSrcweir $self->{CVS_MIRROR_ROOT} = $cvs_mirror_root; 197*cdf0e10cSrcweir } 198*cdf0e10cSrcweir return $self->{CVS_MIRROR_ROOT} ? $self->{CVS_MIRROR_ROOT} : undef; 199*cdf0e10cSrcweir} 200*cdf0e10cSrcweir 201*cdf0e10cSrcweirsub cvs_local_root 202*cdf0e10cSrcweir{ 203*cdf0e10cSrcweir my $self = shift; 204*cdf0e10cSrcweir 205*cdf0e10cSrcweir if ( !defined($self->{CVS_LOCAL_ROOT}) ) { 206*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 207*cdf0e10cSrcweir my $cvs_local_root = $config_file->{CWS_CONFIG}->{'CVS_LOCAL_ROOT'}; 208*cdf0e10cSrcweir if ( !defined($cvs_local_root) ) { 209*cdf0e10cSrcweir $cvs_local_root = ""; 210*cdf0e10cSrcweir } 211*cdf0e10cSrcweir $self->{CVS_LOCAL_ROOT} = $cvs_local_root; 212*cdf0e10cSrcweir } 213*cdf0e10cSrcweir return $self->{CVS_LOCAL_ROOT} ? $self->{CVS_LOCAL_ROOT} : undef; 214*cdf0e10cSrcweir} 215*cdf0e10cSrcweir 216*cdf0e10cSrcweirsub get_cvs_server 217*cdf0e10cSrcweir{ 218*cdf0e10cSrcweir my $self = shift; 219*cdf0e10cSrcweir 220*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER'); 221*cdf0e10cSrcweir return $server; 222*cdf0e10cSrcweir} 223*cdf0e10cSrcweir 224*cdf0e10cSrcweirsub get_cvs_mirror 225*cdf0e10cSrcweir{ 226*cdf0e10cSrcweir my $self = shift; 227*cdf0e10cSrcweir 228*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR'); 229*cdf0e10cSrcweir return $server; 230*cdf0e10cSrcweir} 231*cdf0e10cSrcweir 232*cdf0e10cSrcweirsub get_cvs_local 233*cdf0e10cSrcweir{ 234*cdf0e10cSrcweir my $self = shift; 235*cdf0e10cSrcweir 236*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL'); 237*cdf0e10cSrcweir return $server; 238*cdf0e10cSrcweir} 239*cdf0e10cSrcweir 240*cdf0e10cSrcweirsub get_cvs_server_method 241*cdf0e10cSrcweir{ 242*cdf0e10cSrcweir my $self = shift; 243*cdf0e10cSrcweir 244*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER'); 245*cdf0e10cSrcweir return $method; 246*cdf0e10cSrcweir} 247*cdf0e10cSrcweir 248*cdf0e10cSrcweirsub get_cvs_mirror_method 249*cdf0e10cSrcweir{ 250*cdf0e10cSrcweir my $self = shift; 251*cdf0e10cSrcweir 252*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR'); 253*cdf0e10cSrcweir return $method; 254*cdf0e10cSrcweir} 255*cdf0e10cSrcweir 256*cdf0e10cSrcweirsub get_cvs_local_method 257*cdf0e10cSrcweir{ 258*cdf0e10cSrcweir my $self = shift; 259*cdf0e10cSrcweir 260*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL'); 261*cdf0e10cSrcweir return $method; 262*cdf0e10cSrcweir} 263*cdf0e10cSrcweir 264*cdf0e10cSrcweirsub get_cvs_server_repository 265*cdf0e10cSrcweir{ 266*cdf0e10cSrcweir my $self = shift; 267*cdf0e10cSrcweir 268*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER'); 269*cdf0e10cSrcweir return $repository; 270*cdf0e10cSrcweir} 271*cdf0e10cSrcweir 272*cdf0e10cSrcweirsub get_cvs_mirror_repository 273*cdf0e10cSrcweir{ 274*cdf0e10cSrcweir my $self = shift; 275*cdf0e10cSrcweir 276*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR'); 277*cdf0e10cSrcweir return $repository; 278*cdf0e10cSrcweir} 279*cdf0e10cSrcweir 280*cdf0e10cSrcweirsub get_cvs_local_repository 281*cdf0e10cSrcweir{ 282*cdf0e10cSrcweir my $self = shift; 283*cdf0e10cSrcweir 284*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL'); 285*cdf0e10cSrcweir return $repository; 286*cdf0e10cSrcweir} 287*cdf0e10cSrcweir 288*cdf0e10cSrcweirsub get_cvs_server_id 289*cdf0e10cSrcweir{ 290*cdf0e10cSrcweir my $self = shift; 291*cdf0e10cSrcweir 292*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_server_root(), 'SERVER'); 293*cdf0e10cSrcweir return $id; 294*cdf0e10cSrcweir} 295*cdf0e10cSrcweir 296*cdf0e10cSrcweirsub get_cvs_mirror_id 297*cdf0e10cSrcweir{ 298*cdf0e10cSrcweir my $self = shift; 299*cdf0e10cSrcweir 300*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_mirror_root(), 'MIRROR'); 301*cdf0e10cSrcweir return $id; 302*cdf0e10cSrcweir} 303*cdf0e10cSrcweir 304*cdf0e10cSrcweirsub get_cvs_local_id 305*cdf0e10cSrcweir{ 306*cdf0e10cSrcweir my $self = shift; 307*cdf0e10cSrcweir 308*cdf0e10cSrcweir my ($method, $id, $server, $repository) = CwsConfig::split_root($self->cvs_local_root(), 'LOCAL'); 309*cdf0e10cSrcweir return $id; 310*cdf0e10cSrcweir} 311*cdf0e10cSrcweir 312*cdf0e10cSrcweir#### SVN methods #### 313*cdf0e10cSrcweir 314*cdf0e10cSrcweirsub get_ooo_svn_server 315*cdf0e10cSrcweir{ 316*cdf0e10cSrcweir my $self = shift; 317*cdf0e10cSrcweir 318*cdf0e10cSrcweir if ( !defined($self->{SVN_SERVER}) ) { 319*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 320*cdf0e10cSrcweir my $ooo_svn_server = $config_file->{CWS_CONFIG}->{'SVN_SERVER'}; 321*cdf0e10cSrcweir if ( !defined($ooo_svn_server) ) { 322*cdf0e10cSrcweir $ooo_svn_server = ""; 323*cdf0e10cSrcweir } 324*cdf0e10cSrcweir $self->{SVN_SERVER} = $ooo_svn_server; 325*cdf0e10cSrcweir } 326*cdf0e10cSrcweir return $self->{SVN_SERVER} ? $self->{SVN_SERVER} : undef; 327*cdf0e10cSrcweir} 328*cdf0e10cSrcweir 329*cdf0e10cSrcweirsub get_so_svn_server 330*cdf0e10cSrcweir{ 331*cdf0e10cSrcweir my $self = shift; 332*cdf0e10cSrcweir 333*cdf0e10cSrcweir if ( !defined($self->{SO_SVN_SERVER}) ) { 334*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 335*cdf0e10cSrcweir my $so_svn_server = $config_file->{CWS_CONFIG}->{'SO_SVN_SERVER'}; 336*cdf0e10cSrcweir if ( !defined($so_svn_server) ) { 337*cdf0e10cSrcweir $so_svn_server = ""; 338*cdf0e10cSrcweir } 339*cdf0e10cSrcweir $self->{SO_SVN_SERVER} = $so_svn_server; 340*cdf0e10cSrcweir } 341*cdf0e10cSrcweir return $self->{SO_SVN_SERVER} ? $self->{SO_SVN_SERVER} : undef; 342*cdf0e10cSrcweir} 343*cdf0e10cSrcweir 344*cdf0e10cSrcweir#### HG methods #### 345*cdf0e10cSrcweir 346*cdf0e10cSrcweirsub _get_hg_source 347*cdf0e10cSrcweir{ 348*cdf0e10cSrcweir my $self = shift; 349*cdf0e10cSrcweir my $repository_source = shift; 350*cdf0e10cSrcweir if ( !defined($self->{$repository_source}) ) { 351*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 352*cdf0e10cSrcweir my $source = $config_file->{CWS_CONFIG}->{$repository_source}; 353*cdf0e10cSrcweir if ( !defined($source) ) { 354*cdf0e10cSrcweir $source = ""; 355*cdf0e10cSrcweir } 356*cdf0e10cSrcweir $self->{$repository_source} = $source; 357*cdf0e10cSrcweir } 358*cdf0e10cSrcweir return $self->{$repository_source} ? $self->{$repository_source} : undef; 359*cdf0e10cSrcweir 360*cdf0e10cSrcweir} 361*cdf0e10cSrcweir 362*cdf0e10cSrcweirsub get_hg_source 363*cdf0e10cSrcweir{ 364*cdf0e10cSrcweir my $self = shift; 365*cdf0e10cSrcweir my $repository = shift; 366*cdf0e10cSrcweir my $location = shift; 367*cdf0e10cSrcweir 368*cdf0e10cSrcweir #Special prefix handling, see cwsrc 369*cdf0e10cSrcweir if ($repository eq "OOO") 370*cdf0e10cSrcweir { 371*cdf0e10cSrcweir if ($location eq "LOCAL") 372*cdf0e10cSrcweir { 373*cdf0e10cSrcweir return $self->_get_hg_source('HG_LOCAL_SOURCE'); 374*cdf0e10cSrcweir } 375*cdf0e10cSrcweir elsif ($location eq "LAN") 376*cdf0e10cSrcweir { 377*cdf0e10cSrcweir return $self->_get_hg_source('HG_LAN_SOURCE'); 378*cdf0e10cSrcweir } 379*cdf0e10cSrcweir elsif ($location eq "REMOTE") 380*cdf0e10cSrcweir { 381*cdf0e10cSrcweir return $self->_get_hg_source('HG_REMOTE_SOURCE'); 382*cdf0e10cSrcweir } 383*cdf0e10cSrcweir } 384*cdf0e10cSrcweir else 385*cdf0e10cSrcweir { 386*cdf0e10cSrcweir if ($location eq "LOCAL") 387*cdf0e10cSrcweir { 388*cdf0e10cSrcweir return $self->_get_hg_source($repository.'_HG_LOCAL_SOURCE'); 389*cdf0e10cSrcweir } 390*cdf0e10cSrcweir elsif ($location eq "LAN") 391*cdf0e10cSrcweir { 392*cdf0e10cSrcweir return $self->_get_hg_source($repository.'_HG_LAN_SOURCE'); 393*cdf0e10cSrcweir } 394*cdf0e10cSrcweir elsif ($location eq "REMOTE") 395*cdf0e10cSrcweir { 396*cdf0e10cSrcweir return $self->_get_hg_source($repository.'_HG_REMOTE_SOURCE'); 397*cdf0e10cSrcweir } 398*cdf0e10cSrcweir } 399*cdf0e10cSrcweir} 400*cdf0e10cSrcweir 401*cdf0e10cSrcweir#### Prebuild binaries configuration #### 402*cdf0e10cSrcweir 403*cdf0e10cSrcweirsub get_prebuild_binaries_location 404*cdf0e10cSrcweir{ 405*cdf0e10cSrcweir my $self = shift; 406*cdf0e10cSrcweir 407*cdf0e10cSrcweir if ( !defined($self->{PREBUILD_BINARIES}) ) { 408*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 409*cdf0e10cSrcweir my $pre_build_binaries = $config_file->{CWS_CONFIG}->{'PREBUILD_BINARIES'}; 410*cdf0e10cSrcweir if ( !defined($pre_build_binaries) ) { 411*cdf0e10cSrcweir $pre_build_binaries = ""; 412*cdf0e10cSrcweir } 413*cdf0e10cSrcweir $self->{PREBUILD_BINARIES} = $pre_build_binaries; 414*cdf0e10cSrcweir } 415*cdf0e10cSrcweir return $self->{PREBUILD_BINARIES} ? $self->{PREBUILD_BINARIES} : undef; 416*cdf0e10cSrcweir} 417*cdf0e10cSrcweir 418*cdf0e10cSrcweir 419*cdf0e10cSrcweir 420*cdf0e10cSrcweir#### class methods ##### 421*cdf0e10cSrcweirsub get_config 422*cdf0e10cSrcweir{ 423*cdf0e10cSrcweir my $config = CwsConfig->new(); 424*cdf0e10cSrcweir return $config; 425*cdf0e10cSrcweir} 426*cdf0e10cSrcweir 427*cdf0e10cSrcweirsub split_root 428*cdf0e10cSrcweir{ 429*cdf0e10cSrcweir my $root = shift; 430*cdf0e10cSrcweir my $type = shift; 431*cdf0e10cSrcweir 432*cdf0e10cSrcweir if ( !defined($root) ) { 433*cdf0e10cSrcweir return (undef, undef, undef, undef); 434*cdf0e10cSrcweir } 435*cdf0e10cSrcweir 436*cdf0e10cSrcweir my ($dummy, $method, $id_at_host, $repository) = split(/:/, $root); 437*cdf0e10cSrcweir $repository =~ s/^\d*//; 438*cdf0e10cSrcweir my ($id, $server); 439*cdf0e10cSrcweir if ( $id_at_host ) { 440*cdf0e10cSrcweir ($id, $server) = split(/@/, $id_at_host); 441*cdf0e10cSrcweir } 442*cdf0e10cSrcweir if ( !defined($method) || !defined($id) || !defined($server) || !defined($repository) ) { 443*cdf0e10cSrcweir # give up 444*cdf0e10cSrcweir print "$method, $id, $server, $repository\n"; 445*cdf0e10cSrcweir croak("ERROR: can't parse CVS_".$type."_ROOT entry in '\$HOME/.cwsrc'.\n"); 446*cdf0e10cSrcweir } 447*cdf0e10cSrcweir return ($method, $id, $server, $repository); 448*cdf0e10cSrcweir} 449*cdf0e10cSrcweir 450*cdf0e10cSrcweir#### private helper methods #### 451*cdf0e10cSrcweir 452*cdf0e10cSrcweirsub get_config_file 453*cdf0e10cSrcweir{ 454*cdf0e10cSrcweir my $self = shift; 455*cdf0e10cSrcweir 456*cdf0e10cSrcweir if ( !defined $self->{_CONFIG_FILE} ) { 457*cdf0e10cSrcweir $self->parse_config_file(); 458*cdf0e10cSrcweir } 459*cdf0e10cSrcweir return $self->{_CONFIG_FILE}; 460*cdf0e10cSrcweir} 461*cdf0e10cSrcweir 462*cdf0e10cSrcweirsub read_config 463*cdf0e10cSrcweir{ 464*cdf0e10cSrcweir my $self = shift; 465*cdf0e10cSrcweir my $fname = shift; 466*cdf0e10cSrcweir my $fhandle; 467*cdf0e10cSrcweir my $section = ''; 468*cdf0e10cSrcweir my %config; 469*cdf0e10cSrcweir 470*cdf0e10cSrcweir open ($fhandle, $fname) || croak("ERROR: Can't open '$fname': $!"); 471*cdf0e10cSrcweir while ( <$fhandle> ) { 472*cdf0e10cSrcweir tr/\r\n//d; # win32 pain 473*cdf0e10cSrcweir # Issue #i62815#: Scrambled CVS passwords may contain one or more '#'. 474*cdf0e10cSrcweir # Ugly special case needed: still allow in-line (perl style) comments 475*cdf0e10cSrcweir # elsewhere because existing configuration files may depend on them. 476*cdf0e10cSrcweir if ( !/^\s*CVS_PASSWORD/ ) { 477*cdf0e10cSrcweir s/\#.*//; # kill comments 478*cdf0e10cSrcweir } 479*cdf0e10cSrcweir /^\s*$/ && next; 480*cdf0e10cSrcweir 481*cdf0e10cSrcweir if (/\[\s*(\S+)\s*\]/) { 482*cdf0e10cSrcweir $section = $1; 483*cdf0e10cSrcweir if (!defined $config{$section}) { 484*cdf0e10cSrcweir $config{$section} = {}; 485*cdf0e10cSrcweir } 486*cdf0e10cSrcweir } 487*cdf0e10cSrcweir defined $config{$section} || croak("ERROR: unknown / no section '$section'\n"); 488*cdf0e10cSrcweir if ( m/(\w[\w\d]*)=(.*)/ ) { 489*cdf0e10cSrcweir my $var = $1; 490*cdf0e10cSrcweir my $val = $2; 491*cdf0e10cSrcweir # New style value strings may be surrounded by quotes 492*cdf0e10cSrcweir if ( $val =~ s/\s*(['"])(.*)\1\s*$/$2/ ) { 493*cdf0e10cSrcweir my $quote = $1; 494*cdf0e10cSrcweir # If and only if the value string is surrounded by quotes we 495*cdf0e10cSrcweir # can expect that \" or \' are escaped characters. In an unquoted 496*cdf0e10cSrcweir # old style value string they could mean exactly what is standing there 497*cdf0e10cSrcweir # 498*cdf0e10cSrcweir # Actually the RE above works without quoting the quote character 499*cdf0e10cSrcweir # (either " or ') inside the value string but users will probably 500*cdf0e10cSrcweir # expect that they need to be escaped if quotes are used. 501*cdf0e10cSrcweir # 502*cdf0e10cSrcweir # This is still not completly correct for all thinkable situations but 503*cdf0e10cSrcweir # should be good enough for all practical use cases. 504*cdf0e10cSrcweir $val =~ s/\\($quote)/$1/g; 505*cdf0e10cSrcweir } 506*cdf0e10cSrcweir $config{$section}->{$var} = $val; 507*cdf0e10cSrcweir # print "Set '$var' to '$val'\n"; 508*cdf0e10cSrcweir } 509*cdf0e10cSrcweir } 510*cdf0e10cSrcweir close ($fhandle) || croak("ERROR: Failed to close: $!"); 511*cdf0e10cSrcweir 512*cdf0e10cSrcweir $self->{_CONFIG_FILE} = \%config; 513*cdf0e10cSrcweir} 514*cdf0e10cSrcweir 515*cdf0e10cSrcweirsub parse_config_file 516*cdf0e10cSrcweir{ 517*cdf0e10cSrcweir my $self = shift; 518*cdf0e10cSrcweir 519*cdf0e10cSrcweir my $config_file; 520*cdf0e10cSrcweir # check for config files 521*cdf0e10cSrcweir if ( -e "$ENV{HOME}/.cwsrc" ) { 522*cdf0e10cSrcweir $self->read_config("$ENV{HOME}/.cwsrc"); 523*cdf0e10cSrcweir $self->{_GLOBAL} = 0; 524*cdf0e10cSrcweir } 525*cdf0e10cSrcweir elsif ( -e "$ENV{COMMON_ENV_TOOLS}/cwsrc" ) { 526*cdf0e10cSrcweir $self->read_config("$ENV{COMMON_ENV_TOOLS}/cwsrc"); 527*cdf0e10cSrcweir $self->{_GLOBAL} = 1; 528*cdf0e10cSrcweir } 529*cdf0e10cSrcweir else { 530*cdf0e10cSrcweir croak("ERROR: can't find CWS config file '\$HOME/.cwsrc'.\n"); 531*cdf0e10cSrcweir } 532*cdf0e10cSrcweir} 533*cdf0e10cSrcweir 534*cdf0e10cSrcweirsub sointernal 535*cdf0e10cSrcweir{ 536*cdf0e10cSrcweir my $self = shift; 537*cdf0e10cSrcweir my $config_file = $self->get_config_file(); 538*cdf0e10cSrcweir my $val = ($config_file->{CWS_CONFIG}->{"SO_INTERNAL"}) ? 1 : 0; 539*cdf0e10cSrcweir return $val; 540*cdf0e10cSrcweir} 541*cdf0e10cSrcweir1; # needed by "use" or "require" 542