solenv/bin/modules/CwsConfig.pm

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