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