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