HG_REPOSITORIES/LPP/INSTRUMENTATION/USERS/JEANDET/qtcharts Commit - r1132:f8e33580b2a2

1

package Config::IniFiles;

2

3

use vars qw($VERSION);

4

5

$VERSION = '2.72';

6

7

require 5.004;

8

use strict;

9

use warnings;

10

use Carp;

11

use Symbol 'gensym','qualify_to_ref'; # For the 'any data type' hack

12

use Fcntl qw( SEEK_SET SEEK_CUR );

13

14

use List::MoreUtils qw(any none);

15

16

use File::Basename qw( dirname );

17

use File::Temp qw/ tempfile /;

18

19

@Config::IniFiles::errors = ( );

20

21

# $Header: /home/shlomi/progs/perl/cpan/Config/IniFiles/config-inifiles-cvsbackup/config-inifiles/IniFiles.pm,v 2.41 2003-12-08 10:50:56 domq Exp $

22

23

=head1 NAME

24

25

Config::IniFiles - A module for reading .ini-style configuration files.

26

27

=head1 SYNOPSIS

28

29

use Config::IniFiles;

30

my $cfg = Config::IniFiles->new( -file => "/path/configfile.ini" );

31

print "The value is " . $cfg->val( 'Section', 'Parameter' ) . "."

32

if $cfg->val( 'Section', 'Parameter' );

33

34

=head1 DESCRIPTION

35

36

Config::IniFiles provides a way to have readable configuration files outside

37

your Perl script. Configurations can be imported (inherited, stacked,...),

38

sections can be grouped, and settings can be accessed from a tied hash.

39

40

=head1 FILE FORMAT

41

42

INI files consist of a number of sections, each preceded with the

43

section name in square brackets, followed by parameter names and

44

their values.

45

46

[a section]

47

Parameter=Value

48

49

[section 2]

50

AnotherParameter=Some value

51

Setting=Something else

52

Parameter=Different scope than the one in the first section

53

54

The first non-blank character of the line indicating a section must

55

be a left bracket and the last non-blank character of a line indicating

56

a section must be a right bracket. The characters making up the section

57

name can be any symbols at all. However section names must be unique.

58

59

Parameters are specified in each section as Name=Value. Any spaces

60

around the equals sign will be ignored, and the value extends to the

61

end of the line (including any whitespace at the end of the line.

62

Parameter names are localized to the namespace of the section, but must

63

be unique within a section.

64

65

Both the hash mark (#) and the semicolon (;) are comment characters.

66

by default (this can be changed by configuration). Lines that begin with

67

either of these characters will be ignored. Any amount of whitespace may

68

precede the comment character.

69

70

Multi-line or multi-valued parameters may also be defined ala UNIX

71

"here document" syntax:

72

73

Parameter=<<EOT

74

value/line 1

75

value/line 2

76

EOT

77

78

You may use any string you want in place of "EOT". Note that whatever

79

follows the "<<" and what appears at the end of the text MUST match

80

exactly, including any trailing whitespace.

81

82

Alternately, as a configuration option (default is off), continuation

83

lines can be allowed:

84

85

[Section]

86

Parameter=this parameter \

87

spreads across \

88

a few lines

89

90

91

=head1 USAGE -- Object Interface

92

93

Get a new Config::IniFiles object with the I<new> method:

94

95

$cfg = Config::IniFiles->new( -file => "/path/config_file.ini" );

96

$cfg = new Config::IniFiles -file => "/path/config_file.ini";

97

98

Optional named parameters may be specified after the configuration

99

file name. See the I<new> in the B<METHODS> section, below.

100

101

Values from the config file are fetched with the val method:

102

103

$value = $cfg->val('Section', 'Parameter');

104

105

If you want a multi-line/value field returned as an array, just

106

specify an array as the receiver:

107

108

@values = $cfg->val('Section', 'Parameter');

109

110

=head1 METHODS

111

112

=head2 new ( [-option=>value ...] )

113

114

Returns a new configuration object (or "undef" if the configuration

115

file has an error, in which case check the global C<@Config::IniFiles::errors>

116

array for reasons why). One Config::IniFiles object is required per configuration

117

file. The following named parameters are available:

118

119

=over 10

120

121

122

=item I<-file> filename

123

124

Specifies a file to load the parameters from. This 'file' may actually be

125

any of the following things:

126

127

1) the pathname of a file

128

129

$cfg = Config::IniFiles->new( -file => "/path/to/config_file.ini" );

130

131

2) a simple filehandle

132

133

$cfg = Config::IniFiles->new( -file => STDIN );

134

135

3) a filehandle glob

136

137

open( CONFIG, "/path/to/config_file.ini" );

138

$cfg = Config::IniFiles->new( -file => *CONFIG );

139

140

4) a reference to a glob

141

142

open( CONFIG, "/path/to/config_file.ini" );

143

$cfg = Config::IniFiles->new( -file => \*CONFIG );

144

145

5) an IO::File object

146

147

$io = IO::File->new( "/path/to/config_file.ini" );

148

$cfg = Config::IniFiles->new( -file => $io );

149

150

or

151

152

open my $fh, '<', "/path/to/config_file.ini" or die $!;

153

$cfg = Config::IniFiles->new( -file => $fh );

154

155

6) A reference to a scalar (requires newer versions of IO::Scalar)

156

157

$ini_file_contents = <<EOT

158

[section name]

159

Parameter=A value

160

Setting=Another value

161

EOT

162

163

$cfg = Config::IniFiles->new( -file => \$ini_file_contents );

164

165

166

If this option is not specified, (i.e. you are creating a config file from scratch)

167

you must specify a target file using L<SetFileName> in order to save the parameters.

168

169

170

=item I<-default> section

171

172

Specifies a section to be used for default values. For example, in the

173

following configuration file, if you look up the "permissions" parameter

174

in the "joe" section, there is none.

175

176

[all]

177

permissions=Nothing

178

179

[jane]

180

name=Jane

181

permissions=Open files

182

183

[joe]

184

name=Joseph

185

186

If you create your Config::IniFiles object with a default section of "all" like this:

187

188

$cfg = Config::IniFiles->new( -file => "file.ini", -default => "all" );

189

190

Then requsting a value for a "permissions" in the [joe] section will

191

check for a value from [all] before returning undef.

192

193

$permissions = $cfg->val( "joe", "permissions"); // returns "Nothing"

194

195

196

=item I<-fallback> section

197

198

Specifies a section to be used for parameters outside a section. Default is none.

199

Without -fallback specified (which is the default), reading a configuration file

200

which has a parameter outside a section will fail. With this set to, say,

201

"GENERAL", this configuration:

202

203

wrong=wronger

204

205

[joe]

206

name=Joseph

207

208

will be assumed as:

209

210

[GENERAL]

211

wrong=wronger

212

213

[joe]

214

name=Joseph

215

216

Note that Config::IniFiles will also omit the fallback section header when

217

outputing such configuration.

218

219

=item I<-nocase> 0|1

220

221

Set -nocase => 1 to handle the config file in a case-insensitive

222

manner (case in values is preserved, however). By default, config

223

files are case-sensitive (i.e., a section named 'Test' is not the same

224

as a section named 'test'). Note that there is an added overhead for

225

turning off case sensitivity.

226

227

228

=item I<-import> object

229

230

This allows you to import or inherit existing setting from another

231

Config::IniFiles object. When importing settings from another object,

232

sections with the same name will be merged and parameters that are

233

defined in both the imported object and the I<-file> will take the

234

value of given in the I<-file>.

235

236

If a I<-default> section is also given on this call, and it does not

237

coincide with the default of the imported object, the new default

238

section will be used instead. If no I<-default> section is given,

239

then the default of the imported object will be used.

240

241

242

=item I<-allowcontinue> 0|1

243

244

Set -allowcontinue => 1 to enable continuation lines in the config file.

245

i.e. if a line ends with a backslash C<\>, then the following line is

246

appended to the parameter value, dropping the backslash and the newline

247

character(s).

248

249

Default behavior is to keep a trailing backslash C<\> as a parameter

250

value. Note that continuation cannot be mixed with the "here" value

251

syntax.

252

253

254

=item I<-allowempty> 0|1

255

256

If set to 1, then empty files are allowed at L</ReadConfig|ReadConfig()>

257

time. If set to 0 (the default), an empty configuration file is considered

258

an error.

259

260

261

=item I<-negativedeltas> 0|1

262

263

If set to 1 (the default if importing this object from another one),

264

parses and honors lines of the following form in the configuration

265

file:

266

267

; [somesection] is deleted

268

269

or

270

271

[inthissection]

272

; thisparameter is deleted

273

274

If set to 0 (the default if not importing), these comments are treated

275

like ordinary ones.

276

277

The L</WriteConfig|WriteConfig(-delta=>1)> form will output such

278

comments to indicate deleted sections or parameters. This way,

279

reloading a delta file using the same imported object produces the

280

same results in memory again. See L<IMPORT / DELTA FEATURES> for more

281

details.

282

283

=item I<-commentchar> 'char'

284

285

The default comment character is C<#>. You may change this by specifying

286

this option to another character. This can be any character except

287

alphanumeric characters, square brackets or the "equal" sign.

288

289

290

=item I<-allowedcommentchars> 'chars'

291

292

Allowed default comment characters are C<#> and C<;>. By specifying this

293

option you may change the range of characters that are used to denote a

294

comment line to include any set of characters

295

296

Note: that the character specified by B<-commentchar> (see above) is

297

I<always> part of the allowed comment characters.

298

299

Note 2: The given string is evaluated as a regular expression character

300

class, so '\' must be escaped if you wish to use it.

301

302

303

=item I<-reloadwarn> 0|1

304

305

Set -reloadwarn => 1 to enable a warning message (output to STDERR)

306

whenever the config file is reloaded. The reload message is of the

307

form:

308

309

PID <PID> reloading config file <file> at YYYY.MM.DD HH:MM:SS

310

311

Default behavior is to not warn (i.e. -reloadwarn => 0).

312

313

This is generally only useful when using Config::IniFiles in a server

314

or daemon application. The application is still responsible for determining

315

when the object is to be reloaded.

316

317

318

=item I<-nomultiline> 0|1

319

320

Set -nomultiline => 1 to output multi-valued parameter as:

321

322

param=value1

323

param=value2

324

325

instead of the default:

326

327

param=<<EOT

328

value1

329

value2

330

EOT

331

332

As the later might not be compatible with all applications.

333

334

=item I<-handle_trailing_comment> 0|1

335

336

Set -handle_trailing_comment => 1 to enable support of parameter trailing

337

comments.

338

339

For example, if we have a parameter line like this:

340

341

param1=value1;comment1

342

343

by default, handle_trailing_comment will be set to B<0>, and we will get

344

I<value1;comment1> as the value of I<param1>. If we have

345

-handle_trailing_comment set to B<1>, then we will get I<value1>

346

as the value for I<param1>, and I<comment1> as the trailing comment of

347

I<param1>.

348

349

Set and get methods for trailing comments are provided as

350

L</SetParameterTrailingComment> and L</GetParameterTrailingComment>.

351

352

=back

353

354

=cut

355

356

sub _nocase

357

{

358

my $self = shift;

359

360

if (@_)

361

{

362

$self->{nocase} = (shift(@_) ? 1 : 0);

363

}

364

365

return $self->{nocase};

366

}

367

368

sub _is_parm_in_sect

369

{

370

my ($self, $sect, $parm) = @_;

371

372

return any { $_ eq $parm } @{$self->{myparms}{$sect}};

373

}

374

375

sub new {

376

my $class = shift;

377

my %parms = @_;

378

379

my $errs = 0;

380

my @groups = ( );

381

382

my $self = bless {

383

default => '',

384

fallback =>undef,

385

fallback_used => 0,

386

imported =>undef,

387

v =>{},

388

cf => undef,

389

firstload => 1,

390

nomultiline => 0,

391

handle_trailing_comment => 0,

392

}, $class;

393

394

if( ref($parms{-import}) && ($parms{-import}->isa('Config::IniFiles')) ) {

395

$self->{imported}=$parms{-import}; # ReadConfig will load the data

396

$self->{negativedeltas}=1;

397

} elsif( defined $parms{-import} ) {

398

carp "Invalid -import value \"$parms{-import}\" was ignored.";

399

} # end if

400

delete $parms{-import};

401

402

# Copy the original parameters so we

403

# can use them when we build new sections

404

%{$self->{startup_settings}} = %parms;

405

406

# Parse options

407

my($k, $v);

408

local $_;

409

$self->_nocase(0);

410

411

# Handle known parameters first in this order,

412

# because each() could return parameters in any order

413

if (defined ($v = delete $parms{'-file'})) {

414

# Should we be pedantic and check that the file exists?

415

# .. no, because now it could be a handle, IO:: object or something else

416

$self->{cf} = $v;

417

}

418

if (defined ($v = delete $parms{'-nocase'})) {

419

$self->_nocase($v);

420

}

421

if (defined ($v = delete $parms{'-default'})) {

422

$self->{default} = $self->_nocase ? lc($v) : $v;

423

}

424

if (defined ($v = delete $parms{'-fallback'})) {

425

$self->{fallback} = $self->_nocase ? lc($v) : $v;

426

}

427

if (defined ($v = delete $parms{'-reloadwarn'})) {

428

$self->{reloadwarn} = $v ? 1 : 0;

429

}

430

if (defined ($v = delete $parms{'-nomultiline'})) {

431

$self->{nomultiline} = $v ? 1 : 0;

432

}

433

if (defined ($v = delete $parms{'-allowcontinue'})) {

434

$self->{allowcontinue} = $v ? 1 : 0;

435

}

436

if (defined ($v = delete $parms{'-allowempty'})) {

437

$self->{allowempty} = $v ? 1 : 0;

438

}

439

if (defined ($v = delete $parms{'-negativedeltas'})) {

440

$self->{negativedeltas} = $v ? 1 : 0;

441

}

442

if (defined ($v = delete $parms{'-commentchar'})) {

443

if(!defined $v || length($v) != 1) {

444

carp "Comment character must be unique.";

445

$errs++;

446

}

447

elsif($v =~ /[\[\]=\w]/) {

448

# must not be square bracket, equal sign or alphanumeric

449

carp "Illegal comment character.";

450

$errs++;

451

}

452

else {

453

$self->{comment_char} = $v;

454

}

455

}

456

if (defined ($v = delete $parms{'-allowedcommentchars'})) {

457

# must not be square bracket, equal sign or alphanumeric

458

if(!defined $v || $v =~ /[\[\]=\w]/) {

459

carp "Illegal value for -allowedcommentchars.";

460

$errs++;

461

}

462

else {

463

$self->{allowed_comment_char} = $v;

464

}

465

}

466

467

if (defined ($v = delete $parms{'-handle_trailing_comment'})) {

468

$self->{handle_trailing_comment} = $v ? 1 : 0;

469

}

470

471

$self->{comment_char} = '#' unless exists $self->{comment_char};

472

$self->{allowed_comment_char} = ';' unless exists $self->{allowed_comment_char};

473

# make sure that comment character is always allowed

474

$self->{allowed_comment_char} .= $self->{comment_char};

475

476

$self->{_comments_at_end_of_file} = [];

477

478

# Any other parameters are unkown

479

while (($k, $v) = each %parms) {

480

carp "Unknown named parameter $k=>$v";

481

$errs++;

482

}

483

484

return undef if $errs;

485

486

if ($self->ReadConfig) {

487

return $self;

488

} else {

489

return undef;

490

}

491

}

492

493

494

=head2 val ($section, $parameter [, $default] )

495

496

Returns the value of the specified parameter (C<$parameter>) in section

497

C<$section>, returns undef (or C<$default> if specified) if no section or

498

no parameter for the given section exists.

499

500

501

If you want a multi-line/value field returned as an array, just

502

specify an array as the receiver:

503

504

@values = $cfg->val('Section', 'Parameter');

505

506

A multi-line/value field that is returned in a scalar context will be

507

joined using $/ (input record separator, default is \n) if defined,

508

otherwise the values will be joined using \n.

509

510

=cut

511

512

sub _caseify {

513

my ($self, @refs) = @_;

514

515

if (not $self->_nocase)

516

{

517

return;

518

}

519

520

foreach my $ref (@refs) {

521

${$ref} = lc(${$ref})

522

}

523

524

return;

525

}

526

527

sub val

528

{

529

my ($self, $sect, $parm, $def) = @_;

530

531

# Always return undef on bad parameters

532

if (not (defined($sect) && defined($parm)))

533

{

534

return;

535

}

536

537

$self->_caseify(\$sect, \$parm);

538

539

my $val_sect =

540

defined($self->{v}{$sect}{$parm})

541

? $sect

542

: $self->{default}

543

;

544

545

my $val = $self->{v}{$val_sect}{$parm};

546

547

# If the value is undef, make it $def instead (which could just be undef)

548

if (!defined ($val))

549

{

550

$val = $def;

551

}

552

553

# Return the value in the desired context

554

if (wantarray)

555

{

556

if (ref($val) eq "ARRAY")

557

{

558

return @$val;

559

}

560

elsif (defined($val))

561

{

562

return $val;

563

}

564

else

565

{

566

return;

567

}

568

}

569

elsif (ref($val) eq "ARRAY")

570

{

571

return join( (defined($/) ? $/ : "\n"), @$val);

572

}

573

else

574

{

575

return $val;

576

}

577

}

578

579

=head2 exists($section, $parameter)

580

581

True if and only if there exists a section C<$section>, with

582

a parameter C<$parameter> inside, not counting default values.

583

584

=cut

585

586

sub exists {

587

my ($self, $sect, $parm) = @_;

588

589

$self->_caseify(\$sect, \$parm);

590

591

return (exists $self->{v}{$sect}{$parm});

592

}

593

594

595

596

=head2 push ($section, $parameter, $value, [ $value2, ...])

597

598

Pushes new values at the end of existing value(s) of parameter

599

C<$parameter> in section C<$section>. See below for methods to write

600

the new configuration back out to a file.

601

602

You may not set a parameter that didn't exist in the original

603

configuration file. B<push> will return I<undef> if this is

604

attempted. See B<newval> below to do this. Otherwise, it returns 1.

605

606

=cut

607

608

sub push {

609

my ($self, $sect, $parm, @vals) = @_;

610

611

return undef if not defined $sect;

612

return undef if not defined $parm;

613

614

$self->_caseify(\$sect, \$parm);

615

616

return undef if (! defined($self->{v}{$sect}{$parm}));

617

618

return 1 if (! @vals);

619

620

$self->_touch_parameter($sect, $parm);

621

622

$self->{EOT}{$sect}{$parm} = 'EOT' if

623

(!defined $self->{EOT}{$sect}{$parm});

624

625

$self->{v}{$sect}{$parm} = [$self->{v}{$sect}{$parm}] unless

626

(ref($self->{v}{$sect}{$parm}) eq "ARRAY");

627

628

CORE::push @{$self->{v}{$sect}{$parm}}, @vals;

629

return 1;

630

}

631

632

=head2 setval ($section, $parameter, $value, [ $value2, ... ])

633

634

Sets the value of parameter C<$parameter> in section C<$section> to

635

C<$value> (or to a set of values). See below for methods to write

636

the new configuration back out to a file.

637

638

You may not set a parameter that didn't exist in the original

639

configuration file. B<setval> will return I<undef> if this is

640

attempted. See B<newval> below to do this. Otherwise, it returns 1.

641

642

=cut

643

644

sub setval {

645

my $self = shift;

646

my $sect = shift;

647

my $parm = shift;

648

my @val = @_;

649

650

return undef if not defined $sect;

651

return undef if not defined $parm;

652

653

$self->_caseify(\$sect, \$parm);

654

655

if (defined($self->{v}{$sect}{$parm})) {

656

$self->_touch_parameter($sect, $parm);

657

if (@val > 1) {

658

$self->{v}{$sect}{$parm} = \@val;

659

$self->{EOT}{$sect}{$parm} = 'EOT';

660

} else {

661

$self->{v}{$sect}{$parm} = shift @val;

662

}

663

return 1;

664

} else {

665

return undef;

666

}

667

}

668

669

=head2 newval($section, $parameter, $value [, $value2, ...])

670

671

Assignes a new value, C<$value> (or set of values) to the

672

parameter C<$parameter> in section C<$section> in the configuration

673

file.

674

675

=cut

676

677

sub newval {

678

my $self = shift;

679

my $sect = shift;

680

my $parm = shift;

681

my @val = @_;

682

683

return undef if not defined $sect;

684

return undef if not defined $parm;

685

686

$self->_caseify(\$sect, \$parm);

687

688

$self->AddSection($sect);

689

690

if (none { $_ eq $parm } @{$self->{parms}{$sect}})

691

{

692

CORE::push(@{$self->{parms}{$sect}}, $parm)

693

}

694

695

$self->_touch_parameter($sect, $parm);

696

if (@val > 1) {

697

$self->{v}{$sect}{$parm} = \@val;

698

if (!defined $self->{EOT}{$sect}{$parm})

699

{

700

$self->{EOT}{$sect}{$parm} = 'EOT';

701

}

702

} else {

703

$self->{v}{$sect}{$parm} = shift @val;

704

}

705

return 1

706

}

707

708

=head2 delval($section, $parameter)

709

710

Deletes the specified parameter from the configuration file

711

712

=cut

713

714

sub delval {

715

my $self = shift;

716

my $sect = shift;

717

my $parm = shift;

718

719

return undef if not defined $sect;

720

return undef if not defined $parm;

721

722

$self->_caseify(\$sect, \$parm);

723

724

$self->{parms}{$sect} = [grep {$_ ne $parm} @{$self->{parms}{$sect}}];

725

$self->_touch_parameter($sect, $parm);

726

delete $self->{v}{$sect}{$parm};

727

728

return 1;

729

}

730

731

=head2 ReadConfig

732

733

Forces the configuration file to be re-read. Returns undef if the

734

file can not be opened, no filename was defined (with the C<-file>

735

option) when the object was constructed, or an error occurred while

736

reading.

737

738

If an error occurs while parsing the INI file the @Config::IniFiles::errors

739

array will contain messages that might help you figure out where the

740

problem is in the file.

741

742

=cut

743

744

# Auxillary function to make deep (aliasing-free) copies of data

745

# structures. Ignores blessed objects in tree (could be taught not

746

# to, if needed)

747

sub _deepcopy {

748

my $ref = shift;

749

750

if (! ref($ref)) {

751

return $ref;

752

}

753

754

if (UNIVERSAL::isa($ref, "ARRAY")) {

755

return [map {_deepcopy($_)} @$ref];

756

}

757

758

if (UNIVERSAL::isa($ref, "HASH")) {

759

my $return = {};

760

foreach my $k (keys %$ref) {

761

$return->{$k} = _deepcopy($ref->{$k});

762

}

763

return $return;

764

}

765

766

carp "Unhandled data structure in $ref, cannot _deepcopy()";

767

}

768

769

# Internal method, gets the next line, taking proper care of line endings.

770

sub _nextline {

771

my ($self, $fh) = @_;

772

local $_;

773

if (!exists $self->{line_ends}) {

774

# no $self->{line_ends} is a hint set by caller that we are at

775

# the first line (kludge kludge).

776

{

777

local $/=\1;

778

my $nextchar;

779

do {

780

$nextchar=<$fh>;

781

return undef if (!defined $nextchar);

782

$_ .= $nextchar;

783

} until (m/((\015|\012|\025|\n)$)/s);

784

$self->{line_ends}=$1;

785

if ($nextchar eq "\x0d") {

786

# peek at the next char

787

$nextchar = <$fh>;

788

if ($nextchar eq "\x0a") {

789

$self->{line_ends} .= "\x0a";

790

} else {

791

seek $fh, -1, SEEK_CUR();

792

}

793

}

794

}

795

796

# If there's a UTF BOM (Byte-Order-Mark) in the first

797

# character of the first line then remove it before processing

798

# ( http://www.unicode.org/unicode/faq/utf_bom.html#22 )

799

s/^//;

800

801

return $_;

802

} else {

803

local $/=$self->{line_ends};

804

return scalar <$fh>;

805

}

806

}

807

808

# Internal method, closes or resets the file handle. To be called

809

# whenever ReadConfig() returns.

810

sub _rollback {

811

my ($self, $fh) = @_;

812

# Only close if this is a filename, if it's

813

# an open handle, then just roll back to the start

814

if( !ref($self->{cf}) ) {

815

close($fh);

816

} else {

817

# Attempt to rollback to beginning, no problem if this fails (e.g. STDIN)

818

seek( $fh, 0, SEEK_SET() );

819

} # end if

820

}

821

822

sub _no_filename

823

{

824

my $self = shift;

825

826

return not length $self->{cf};

827

}

828

829

sub _read_line_num

830

{

831

my $self = shift;

832

833

if (@_)

834

{

835

$self->{_read_line_num} = shift;

836

}

837

838

return $self->{_read_line_num};

839

}

840

841

# Reads the next line and removes the end of line from it.

842

sub _read_next_line

843

{

844

my ($self, $fh) = @_;

845

846

my $line = $self->_nextline($fh);

847

848

if (! defined($line))

849

{

850

return undef;

851

}

852

853

$self->_read_line_num( $self->_read_line_num() + 1);

854

855

# Remove line ending char(s)

856

$line =~ s/(\015\012?|\012|\025|\n)\z//;

857

858

return $line;

859

}

860

861

sub _add_error

862

{

863

my ($self, $msg) = @_;

864

865

CORE::push(@Config::IniFiles::errors, $msg);

866

867

return;

868

}

869

870

# The current section - used for parsing.

871

sub _curr_sect

872

{

873

my $self = shift;

874

875

if (@_)

876

{

877

$self->{_curr_sect} = shift;

878

}

879

880

return $self->{_curr_sect};

881

}

882

883

# The current parameter - used for parsing.

884

sub _curr_parm

885

{

886

my $self = shift;

887

888

if (@_)

889

{

890

$self->{_curr_parm} = shift;

891

}

892

893

return $self->{_curr_parm};

894

}

895

896

# Current location - section and parameter.

897

sub _curr_loc

898

{

899

my $self = shift;

900

901

return ($self->_curr_sect, $self->_curr_parm);

902

}

903

904

# The current value - used in parsing.

905

sub _curr_val

906

{

907

my $self = shift;

908

909

if (@_)

910

{

911

$self->{_curr_val} = shift;

912

}

913

914

return $self->{_curr_val};

915

}

916

917

sub _curr_cmts

918

{

919

my $self = shift;

920

921

if (@_)

922

{

923

$self->{_curr_cmts} = shift;

924

}

925

926

return $self->{_curr_cmts};

927

}

928

929

sub _curr_end_comment

930

{

931

my $self = shift;

932

933

if (@_)

934

{

935

$self->{_curr_end_comment} = shift;

936

}

937

938

return $self->{_curr_end_comment};

939

}

940

941

my $RET_CONTINUE = 1;

942

my $RET_BREAK;

943

944

sub _ReadConfig_handle_comment

945

{

946

my ($self, $line) = @_;

947

948

if ($self->{negativedeltas} and

949

my ($to_delete) = $line =~ m/\A$self->{comment_char} (.*) is deleted\z/

950

)

951

{

952

if (my ($sect) = $to_delete =~ m/\A\[(.*)\]\z/)

953

{

954

$self->DeleteSection($sect);

955

}

956

else

957

{

958

$self->delval($self->_curr_sect, $to_delete);

959

}

960

}

961

else

962

{

963

CORE::push(@{$self->_curr_cmts}, $line);

964

}

965

966

return $RET_CONTINUE;

967

}

968

969

sub _ReadConfig_new_section

970

{

971

my ($self, $sect) = @_;

972

973

$self->_caseify(\$sect);

974

975

$self->_curr_sect($sect);

976

$self->AddSection($self->_curr_sect);

977

$self->SetSectionComment($self->_curr_sect, @{$self->_curr_cmts});

978

$self->_curr_cmts([]);

979

980

return $RET_CONTINUE;

981

}

982

983

sub _handle_fallback_sect

984

{

985

my ($self) = @_;

986

987

if ((!defined($self->_curr_sect)) and defined($self->{fallback}))

988

{

989

$self->_curr_sect($self->{fallback});

990

$self->{fallback_used}++;

991

}

992

993

return;

994

}

995

996

sub _ReadConfig_load_value

997

{

998

my ($self, $val_aref) = @_;

999

1000

# Now load value

1001

if (exists $self->{v}{$self->_curr_sect}{$self->_curr_parm} &&

1002

exists $self->{myparms}{$self->_curr_sect} &&

1003

$self->_is_parm_in_sect($self->_curr_loc))

1004

{

1005

$self->push($self->_curr_loc, @$val_aref);

1006

}

1007

else

1008

{

1009

# Loaded parameters shadow imported ones, instead of appending

1010

# to them

1011

$self->newval($self->_curr_loc, @$val_aref);

1012

}

1013

1014

return;

1015

}

1016

1017

sub _test_for_fallback_or_no_sect

1018

{

1019

my ($self, $fh) = @_;

1020

1021

$self->_handle_fallback_sect;

1022

1023

if (!defined $self->_curr_sect) {

1024

$self->_add_error(

1025

sprintf('%d: %s', $self->_read_line_num(),

1026

qq#parameter found outside a section#

1027

)

1028

);

1029

$self->_rollback($fh);

1030

return $RET_BREAK;

1031

}

1032

1033

return $RET_CONTINUE;

1034

}

1035

1036

sub _ReadConfig_handle_here_doc_param

1037

{

1038

my ($self, $fh, $eotmark, $val_aref) = @_;

1039

1040

my $foundeot = 0;

1041

my $startline = $self->_read_line_num();

1042

1043

HERE_DOC_LOOP:

1044

while (defined( my $line = $self->_read_next_line($fh) ))

1045

{

1046

if ($line eq $eotmark)

1047

{

1048

$foundeot = 1;

1049

last HERE_DOC_LOOP;

1050

}

1051

else

1052

{

1053

# Untaint

1054

my ($contents) = $line =~ /(.*)/ms;

1055

CORE::push(@$val_aref, $contents);

1056

}

1057

}

1058

1059

if (! $foundeot)

1060

{

1061

$self->_add_error(sprintf('%d: %s', $startline,

1062

qq#no end marker ("$eotmark") found#));

1063

$self->_rollback();

1064

return $RET_BREAK;

1065

}

1066

1067

return $RET_CONTINUE;

1068

}

1069

1070

sub _ReadConfig_handle_non_here_doc_param

1071

{

1072

my ($self, $fh, $val_aref) = @_;

1073

1074

my $allCmt = $self->{allowed_comment_char};

1075

my $end_commenthandle = $self->{handle_trailing_comment};

1076

1077

# process continuation lines, if any

1078

$self->_process_continue_val($fh);

1079

1080

# we should split value and comments if there is any comment

1081

if ($end_commenthandle and

1082

my ($value_to_assign, $end_comment_to_assign) = $self->_curr_val =~ /(.*?)\s*[$allCmt]\s*([^$allCmt]*)$/)

1083

{

1084

$self->_curr_val($value_to_assign);

1085

$self->_curr_end_comment($end_comment_to_assign);

1086

}

1087

else

1088

{

1089

$self->_curr_end_comment(q{});

1090

}

1091

1092

@{$val_aref} = ($self->_curr_val);

1093

1094

return;

1095

}

1096

1097

1098

sub _ReadConfig_populate_values

1099

{

1100

my ($self, $val_aref, $eotmark) = @_;

1101

1102

$self->_ReadConfig_load_value($val_aref);

1103

1104

$self->SetParameterComment($self->_curr_loc, @{ $self->_curr_cmts });

1105

$self->_curr_cmts([]);

1106

if (defined $eotmark)

1107

{

1108

$self->SetParameterEOT($self->_curr_loc, $eotmark);

1109

}

1110

# if handle_trailing_comment is off, this line makes no sense, since all $end_comment=""

1111

$self->SetParameterTrailingComment($self->_curr_loc, $self->_curr_end_comment);

1112

1113

return;

1114

}

1115

1116

sub _ReadConfig_param_assignment

1117

{

1118

my ($self, $fh, $line, $parm, $value_to_assign) = @_;

1119

1120

$self->_curr_val($value_to_assign);

1121

$self->_curr_end_comment(undef());

1122

1123

if (!defined( $self->_test_for_fallback_or_no_sect($fh) ))

1124

{

1125

return $RET_BREAK;

1126

}

1127

1128

$self->_caseify(\$parm);

1129

$self->_curr_parm($parm);

1130

1131

my @val = ( );

1132

my $eotmark;

1133

1134

if (($eotmark) = $self->_curr_val =~ /\A<<(.*)$/)

1135

{

1136

if (! defined($self->_ReadConfig_handle_here_doc_param(

1137

$fh, $eotmark, \@val

1138

))

1139

)

1140

{

1141

return $RET_BREAK;

1142

}

1143

}

1144

else

1145

{

1146

$self->_ReadConfig_handle_non_here_doc_param( $fh, \@val );

1147

}

1148

1149

$self->_ReadConfig_populate_values(\@val, $eotmark);

1150

1151

return $RET_CONTINUE;

1152

}

1153

1154

# Return 1 to continue - undef to terminate the loop.

1155

sub _ReadConfig_handle_line

1156

{

1157

my ($self, $fh, $line) = @_;

1158

1159

my $allCmt = $self->{allowed_comment_char};

1160

1161

# ignore blank lines

1162

if ($line =~ /\A\s*\z/)

1163

{

1164

return $RET_CONTINUE;

1165

}

1166

1167

# collect comments

1168

if ($line =~/\A\s*[$allCmt]/)

1169

{

1170

return $self->_ReadConfig_handle_comment($line);

1171

}

1172

1173

# New Section

1174

if (my ($sect) = $line =~ /\A\s*\[\s*(\S|\S.*\S)\s*\]\s*\z/)

1175

{

1176

return $self->_ReadConfig_new_section($sect);

1177

}

1178

1179

# New parameter

1180

if (my ($parm, $value_to_assign) = $line =~ /^\s*([^=]*?[^=\s])\s*=\s*(.*)$/)

1181

{

1182

return $self->_ReadConfig_param_assignment($fh, $line, $parm, $value_to_assign);

1183

}

1184

1185

$self->_add_error(

1186

sprintf("Line %d in file %s is mal-formed:\n\t\%s",

1187

$self->_read_line_num(), $self->GetFileName(), $line

1188

)

1189

);

1190

1191

return $RET_CONTINUE;

1192

}

1193

1194

sub _ReadConfig_lines_loop

1195

{

1196

my ($self, $fh) = @_;

1197

1198

$self->_curr_sect(undef());

1199

$self->_curr_parm(undef());

1200

$self->_curr_val(undef());

1201

$self->_curr_cmts([]);

1202

1203

while ( defined(my $line = $self->_read_next_line($fh)) )

1204

{

1205

if (!defined(

1206

scalar( $self->_ReadConfig_handle_line($fh, $line) )

1207

)

1208

)

1209

{

1210

return undef;

1211

}

1212

}

1213

1214

return 1;

1215

}

1216

1217

sub ReadConfig

1218

{

1219

my $self = shift;

1220

1221

@Config::IniFiles::errors = ( );

1222

1223

# Initialize (and clear out) storage hashes

1224

$self->{sects} = [];

1225

$self->{parms} = {};

1226

$self->{group} = {};

1227

$self->{v} = {};

1228

$self->{sCMT} = {};

1229

$self->{pCMT} = {};

1230

$self->{EOT} = {};

1231

$self->{mysects} = []; # A pair of hashes to remember which params are loaded

1232

$self->{myparms} = {}; # or set using the API vs. imported - useful for

1233

$self->{peCMT} = {}; # this will store trailing comments at the end of single-lined params

1234

# import shadowing, see below, and WriteConfig(-delta=>1)

1235

1236

if( defined $self->{imported} ) {

1237

# Run up the import tree to the top, then reload coming

1238

# back down, maintaining the imported file names and our

1239

# file name.

1240

# This is only needed on a re-load though

1241

$self->{imported}->ReadConfig() unless ($self->{firstload});

1242

1243

foreach my $field (qw(sects parms group v sCMT pCMT EOT)) {

1244

$self->{$field} = _deepcopy($self->{imported}->{$field});

1245

}

1246

} # end if

1247

1248

if ($self->_no_filename)

1249

{

1250

return 1;

1251

}

1252

1253

# If this is a reload and we want warnings then send one to the STDERR log

1254

unless( $self->{firstload} || !$self->{reloadwarn} ) {

1255

my ($ss, $mm, $hh, $DD, $MM, $YY) = (localtime(time))[0..5];

1256

printf STDERR

1257

"PID %d reloading config file %s at %d.%02d.%02d %02d:%02d:%02d\n",

1258

$$, $self->{cf}, $YY+1900, $MM+1, $DD, $hh, $mm, $ss;

1259

}

1260

1261

# Turn off. Future loads are reloads

1262

$self->{firstload} = 0;

1263

1264

# Get a filehandle, allowing almost any type of 'file' parameter

1265

my $fh = $self->_make_filehandle( $self->{cf} );

1266

if (!$fh) {

1267

carp "Failed to open $self->{cf}: $!";

1268

return undef;

1269

}

1270

1271

# Get mod time of file so we can retain it (if not from STDIN)

1272

# also check if it's a real file (could have been a filehandle made from a scalar).

1273

if (ref($fh) ne "IO::Scalar" && -e $fh)

1274

{

1275

my @stats = stat $fh;

1276

$self->{file_mode} = sprintf("%04o", $stats[2]) if defined $stats[2];

1277

}

1278

1279

1280

# The first lines of the file must be blank, comments or start with [

1281

my $first = '';

1282

1283

delete $self->{line_ends}; # Marks start of parsing for _nextline()

1284

1285

$self->_read_line_num(0);

1286

1287

if (!defined($self->_ReadConfig_lines_loop($fh)))

1288

{

1289

return undef;

1290

}

1291

1292

# Special case: return undef if file is empty. (suppress this line to

1293

# restore the more intuitive behaviour of accepting empty files)

1294

if (! keys %{$self->{v}} && ! $self->{allowempty}) {

1295

$self->_add_error("Empty file treated as error");

1296

$self->_rollback($fh);

1297

return undef;

1298

}

1299

1300

if ( defined (my $defaultsect=$self->{startup_settings}->{-default}) )

1301

{

1302

$self->AddSection($defaultsect);

1303

}

1304

1305

$self->_SetEndComments(@{ $self->_curr_cmts });

1306

1307

$self->_rollback($fh);

1308

return (@Config::IniFiles::errors ? undef : 1);

1309

}

1310

1311

1312

=head2 Sections

1313

1314

Returns an array containing section names in the configuration file.

1315

If the I<nocase> option was turned on when the config object was

1316

created, the section names will be returned in lowercase.

1317

1318

=cut

1319

1320

sub Sections {

1321

my $self = shift;

1322

1323

return @{_aref_or_empty($self->{sects})};

1324

}

1325

1326

=head2 SectionExists ( $sect_name )

1327

1328

Returns 1 if the specified section exists in the INI file, 0 otherwise (undefined if section_name is not defined).

1329

1330

=cut

1331

1332

sub SectionExists {

1333

my $self = shift;

1334

my $sect = shift;

1335

1336

return undef if not defined $sect;

1337

1338

$self->_caseify(\$sect);

1339

1340

return ((any { $_ eq $sect } @{$self->{sects}}) ? 1 : 0);

1341

}

1342

1343

=head2 AddSection ( $sect_name )

1344

1345

Ensures that the named section exists in the INI file. If the section already

1346

exists, nothing is done. In this case, the "new" section will possibly contain

1347

data already.

1348

1349

If you really need to have a new section with no parameters in it, check that

1350

the name that you're adding isn't in the list of sections already.

1351

1352

=cut

1353

1354

sub _AddSection_Helper

1355

{

1356

my ($self, $sect) = @_;

1357

1358

CORE::push @{$self->{sects}}, $sect;

1359

$self->_touch_section($sect);

1360

1361

$self->SetGroupMember($sect);

1362

1363

# Set up the parameter names and values lists

1364

$self->{parms}{$sect} ||= [];

1365

1366

if (!defined($self->{v}{$sect})) {

1367

$self->{sCMT}{$sect} = [];

1368

$self->{pCMT}{$sect} = {}; # Comments above parameters

1369

$self->{parms}{$sect} = [];

1370

$self->{v}{$sect} = {};

1371

}

1372

1373

return;

1374

}

1375

1376

sub AddSection {

1377

my ($self, $sect) = @_;

1378

1379

return undef if not defined $sect;

1380

1381

$self->_caseify(\$sect);

1382

1383

if ( $self->SectionExists($sect))

1384

{

1385

return;

1386

}

1387

1388

return $self->_AddSection_Helper($sect);

1389

}

1390

1391

# Marks a section as modified by us (this includes deleted by us).

1392

sub _touch_section {

1393

my ($self, $sect) = @_;

1394

1395

$self->{mysects} ||= [];

1396

1397

if (none { $_ eq $sect } @{$self->{mysects}})

1398

{

1399

CORE::push @{$self->{mysects}}, $sect;

1400

}

1401

1402

return;

1403

}

1404

1405

# Marks a parameter as modified by us (this includes deleted by us).

1406

sub _touch_parameter {

1407

my ($self, $sect, $parm) = @_;

1408

1409

$self->_touch_section($sect);

1410

return if (!exists $self->{v}{$sect});

1411

$self->{myparms}{$sect} ||= [];

1412

1413

if (! $self->_is_parm_in_sect($sect, $parm))

1414

{

1415

CORE::push @{$self->{myparms}{$sect}}, $parm;

1416

}

1417

1418

return;

1419

}

1420

1421

1422

=head2 DeleteSection ( $sect_name )

1423

1424

Completely removes the entire section from the configuration.

1425

1426

=cut

1427

1428

sub DeleteSection {

1429

my $self = shift;

1430

my $sect = shift;

1431

1432

return undef if not defined $sect;

1433

1434

$self->_caseify(\$sect);

1435

1436

# This is done the fast way, change if data structure changes!!

1437

delete $self->{v}{$sect};

1438

delete $self->{sCMT}{$sect};

1439

delete $self->{pCMT}{$sect};

1440

delete $self->{EOT}{$sect};

1441

delete $self->{parms}{$sect};

1442

delete $self->{myparms}{$sect};

1443

1444

$self->{sects} = [grep {$_ ne $sect} @{$self->{sects}}];

1445

$self->_touch_section($sect);

1446

1447

$self->RemoveGroupMember($sect);

1448

1449

return 1;

1450

} # end DeleteSection

1451

1452

=head2 Parameters ($sect_name)

1453

1454

Returns an array containing the parameters contained in the specified

1455

section.

1456

1457

=cut

1458

1459

sub _aref_or_empty

1460

{

1461

my ($aref) = @_;

1462

1463

return ((defined($aref) and ref($aref) eq 'ARRAY') ? $aref : []);

1464

}

1465

1466

sub Parameters {

1467

my $self = shift;

1468

my $sect = shift;

1469

1470

return undef if not defined $sect;

1471

1472

$self->_caseify(\$sect);

1473

1474

return @{_aref_or_empty($self->{parms}{$sect})};

1475

}

1476

1477

=head2 Groups

1478

1479

Returns an array containing the names of available groups.

1480

1481

Groups are specified in the config file as new sections of the form

1482

1483

[GroupName MemberName]

1484

1485

This is useful for building up lists. Note that parameters within a

1486

"member" section are referenced normally (i.e., the section name is

1487

still "Groupname Membername", including the space) - the concept of

1488

Groups is to aid people building more complex configuration files.

1489

1490

=cut

1491

1492

sub Groups

1493

{

1494

my $self = shift;

1495

1496

if (ref($self->{group}) eq 'HASH')

1497

{

1498

return keys %{$self->{group}};

1499

}

1500

else

1501

{

1502

return ();

1503

}

1504

}

1505

1506

=head2 SetGroupMember ( $sect )

1507

1508

Makes sure that the specified section is a member of the appropriate group.

1509

1510

Only intended for use in newval.

1511

1512

=cut

1513

1514

sub _group_member_handling_skeleton

1515

{

1516

my ($self, $sect, $method) = @_;

1517

1518

return undef if not defined $sect;

1519

1520

if (! (my ($group) = ($sect =~ /\A(\S+)\s+\S/)))

1521

{

1522

return 1;

1523

}

1524

else

1525

{

1526

return $self->$method($sect, $group);

1527

}

1528

}

1529

1530

sub _SetGroupMember_helper

1531

{

1532

my ($self, $sect, $group) = @_;

1533

1534

if (not exists($self->{group}{$group})) {

1535

$self->{group}{$group} = [];

1536

}

1537

1538

if (none {$_ eq $sect} @{$self->{group}{$group}}) {

1539

CORE::push @{$self->{group}{$group}}, $sect;

1540

}

1541

1542

return;

1543

}

1544

1545

sub SetGroupMember {

1546

my ($self, $sect) = @_;

1547

1548

return $self->_group_member_handling_skeleton($sect, '_SetGroupMember_helper');

1549

}

1550

1551

=head2 RemoveGroupMember ( $sect )

1552

1553

Makes sure that the specified section is no longer a member of the

1554

appropriate group. Only intended for use in DeleteSection.

1555

1556

=cut

1557

1558

sub _RemoveGroupMember_helper

1559

{

1560

my ($self, $sect, $group) = @_;

1561

1562

if (!exists $self->{group}{$group})

1563

{

1564

return;

1565

}

1566

1567

$self->{group}{$group} =

1568

[grep { $_ ne $sect } @{$self->{group}{$group}}];

1569

1570

return;

1571

}

1572

1573

sub RemoveGroupMember

1574

{

1575

my ($self, $sect) = @_;

1576

1577

return $self->_group_member_handling_skeleton($sect, '_RemoveGroupMember_helper');

1578

}

1579

1580

=head2 GroupMembers ($group)

1581

1582

Returns an array containing the members of specified $group. Each element

1583

of the array is a section name. For example, given the sections

1584

1585

[Group Element 1]

1586

...

1587

1588

[Group Element 2]

1589

...

1590

1591

GroupMembers would return ("Group Element 1", "Group Element 2").

1592

1593

=cut

1594

1595

sub GroupMembers {

1596

my ($self, $group) = @_;

1597

1598

return undef if not defined $group;

1599

1600

$self->_caseify(\$group);

1601

1602

return @{_aref_or_empty($self->{group}{$group})};

1603

}

1604

1605

=head2 SetWriteMode ($mode)

1606

1607

Sets the mode (permissions) to use when writing the INI file.

1608

1609

$mode must be a string representation of the octal mode.

1610

1611

=cut

1612

1613

sub SetWriteMode

1614

{

1615

my ($self, $mode) = @_;

1616

1617

if (not (defined($mode) && ($mode =~ m/[0-7]{3}/)))

1618

{

1619

return undef;

1620

}

1621

1622

return ($self->{file_mode} = $mode);

1623

}

1624

1625

=head2 GetWriteMode ($mode)

1626

1627

Gets the current mode (permissions) to use when writing the INI file.

1628

1629

$mode is a string representation of the octal mode.

1630

1631

=cut

1632

1633

sub GetWriteMode

1634

{

1635

my $self = shift;

1636

1637

return $self->{file_mode};

1638

}

1639

1640

=head2 WriteConfig ($filename [, %options])

1641

1642

Writes out a new copy of the configuration file. A temporary file

1643

(ending in '-new') is written out and then renamed to the specified

1644

filename. Also see B<BUGS> below.

1645

1646

If C<-delta> is set to a true value in %options, and this object was

1647

imported from another (see L</new>), only the differences between this

1648

object and the imported one will be recorded. Negative deltas will be

1649

encoded into comments, so that a subsequent invocation of I<new()>

1650

with the same imported object produces the same results (see the

1651

I<-negativedeltas> option in L</new>).

1652

1653

C<%options> is not required.

1654

1655

Returns true on success, C<undef> on failure.

1656

1657

=cut

1658

1659

sub _write_config_to_filename

1660

{

1661

my ($self, $filename, %parms) = @_;

1662

1663

if (-e $filename) {

1664

if (not (-w $filename))

1665

{

1666

#carp "File $filename is not writable. Refusing to write config";

1667

return undef;

1668

}

1669

my $mode = (stat $filename)[2];

1670

$self->{file_mode} = sprintf "%04o", ($mode & 0777);

1671

#carp "Using mode $self->{file_mode} for file $file";

1672

}

1673

1674

my ($fh, $new_file) = tempfile(

1675

"temp.ini-XXXXXXXXXX",

1676

DIR => dirname($filename)

1677

);

1678

$self->OutputConfigToFileHandle($fh, $parms{-delta});

1679

close($fh);

1680

if (!rename( $new_file, $filename )) {

1681

carp "Unable to rename temp config file ($new_file) to ${filename}: $!";

1682

return undef;

1683

}

1684

if (exists $self->{file_mode}) {

1685

chmod oct($self->{file_mode}), $filename;

1686

}

1687

1688

return 1;

1689

}

1690

1691

sub _write_config_with_a_made_fh

1692

{

1693

my ($self, $fh, %parms) = @_;

1694

1695

# Only roll back if it's not STDIN (if it is, Carp)

1696

if( $fh == \*STDIN )

1697

{

1698

carp "Cannot write configuration file to STDIN.";

1699

}

1700

else

1701

{

1702

seek( $fh, 0, SEEK_SET() );

1703

$self->OutputConfigToFileHandle($fh, $parms{-delta});

1704

seek( $fh, 0, SEEK_SET() );

1705

} # end if

1706

1707

return 1;

1708

}

1709

1710

sub _write_config_to_fh

1711

{

1712

my ($self, $file, %parms) = @_;

1713

1714

# Get a filehandle, allowing almost any type of 'file' parameter

1715

## NB: If this were a filename, this would fail because _make_file

1716

## opens a read-only handle, but we have already checked that case

1717

## so re-using the logic is ok [JW/WADG]

1718

my $fh = $self->_make_filehandle( $file );

1719

1720

if (!$fh) {

1721

carp "Could not find a filehandle for the input stream ($file): $!";

1722

return undef;

1723

}

1724

1725

return $self->_write_config_with_a_made_fh($fh, %parms);

1726

}

1727

1728

sub WriteConfig {

1729

my ($self, $file, %parms) = @_;

1730

1731

return undef unless defined $file;

1732

1733

# If we are using a filename, then do mode checks and write to a

1734

# temporary file to avoid a race condition

1735

if( !ref($file) )

1736

{

1737

return $self->_write_config_to_filename($file, %parms);

1738

}

1739

# Otherwise, reset to the start of the file and write, unless we are using

1740

# STDIN

1741

else

1742

{

1743

return $self->_write_config_to_fh($file, %parms);

1744

}

1745

}

1746

1747

=head2 RewriteConfig

1748

1749

Same as WriteConfig, but specifies that the original configuration

1750

file should be rewritten.

1751

1752

=cut

1753

1754

sub RewriteConfig {

1755

my $self = shift;

1756

1757

if ($self->_no_filename)

1758

{

1759

return 1;

1760

}

1761

1762

return $self->WriteConfig($self->{cf});

1763

}

1764

1765

=head2 GetFileName

1766

1767

Returns the filename associated with this INI file.

1768

1769

If no filename has been specified, returns undef.

1770

1771

=cut

1772

1773

sub GetFileName

1774

{

1775

my $self = shift;

1776

1777

return $self->{cf};

1778

}

1779

1780

=head2 SetFileName ($filename)

1781

1782

If you created the Config::IniFiles object without initialising from

1783

a file, or if you just want to change the name of the file to use for

1784

ReadConfig/RewriteConfig from now on, use this method.

1785

1786

Returns $filename if that was a valid name, undef otherwise.

1787

1788

=cut

1789

1790

sub SetFileName {

1791

my ($self, $new_filename) = @_;

1792

1793

if ( length($new_filename) > 0 ) {

1794

return ($self->{cf} = $new_filename);

1795

}

1796

else {

1797

return undef;

1798

}

1799

}

1800

1801

=head2 $ini->OutputConfigToFileHandle($fh, $delta)

1802

1803

Writes OutputConfig to the $fh filehandle. $delta should be set to 1

1804

1 if writing only delta. This is a newer and safer version of

1805

C<OutputConfig()> and one is encouraged to use it instead.

1806

1807

=head2 $ini->OutputConfig($delta)

1808

1809

Writes OutputConfig to STDOUT. Use select() to redirect STDOUT to

1810

the output target before calling this function. Optional argument

1811

should be set to 1 if writing only delta. Also see OutputConfigToFileHandle

1812

1813

=cut

1814

1815

sub _calc_eot_mark

1816

{

1817

my ($self, $sect, $parm, $val) = @_;

1818

1819

my $eotmark = $self->{EOT}{$sect}{$parm} || 'EOT';

1820

1821

# Make sure the $eotmark does not occur inside the string.

1822

my @letters = ('A' .. 'Z');

1823

my $joined_val = join(q{ }, @$val);

1824

while (index($joined_val, $eotmark) >= 0)

1825

{

1826

$eotmark .= $letters[rand(@letters)];

1827

}

1828

1829

return $eotmark;

1830

}

1831

1832

sub _OutputParam {

1833

my ($self, $sect, $parm, $val, $end_comment, $output_cb) = @_;

1834

1835

my $line_loop = sub {

1836

my ($mapper) = @_;

1837

1838

foreach my $line (@{$val}[0 .. $#$val-1]) {

1839

$output_cb->($mapper->($line));

1840

}

1841

$output_cb->(

1842

$mapper->($val->[-1]),

1843

($end_comment ? (" $self->{comment_char} $end_comment") : ()),

1844

);

1845

return;

1846

};

1847

1848

if (! @$val) {

1849

# An empty variable - see:

1850

# https://rt.cpan.org/Public/Bug/Display.html?id=68554

1851

$output_cb->("$parm=");

1852

}

1853

elsif ((@$val == 1) or $self->{nomultiline}) {

1854

$line_loop->(sub { my ($line) = @_; return "$parm=$line"; });

1855

}

1856

else

1857

{

1858

my $eotmark = $self->_calc_eot_mark($sect, $parm, $val);

1859

1860

$output_cb->("$parm= <<$eotmark");

1861

$line_loop->(sub { my ($line) = @_; return $line; });

1862

$output_cb->($eotmark);

1863

}

1864

1865

return;

1866

}

1867

1868

sub OutputConfig {

1869

my ($self, $delta) = @_;

1870

1871

return $self->OutputConfigToFileHandle(select(), $delta);

1872

}

1873

1874

sub _output_comments

1875

{

1876

my ($self, $print_line, $comments_aref) = @_;

1877

1878

if (ref($comments_aref) eq 'ARRAY') {

1879

foreach my $comment (@$comments_aref) {

1880

$print_line->($comment);

1881

}

1882

}

1883

1884

return;

1885

}

1886

1887

sub _process_continue_val

1888

{

1889

my ($self, $fh) = @_;

1890

1891

if (not $self->{allowcontinue})

1892

{

1893

return;

1894

}

1895

1896

my $val = $self->_curr_val;

1897

1898

while($val =~ s/\\\z//) {

1899

$val .= $self->_read_next_line($fh);

1900

}

1901

1902

$self->_curr_val($val);

1903

1904

return;

1905

}

1906

1907

sub _output_param_total

1908

{

1909

my ($self, $sect, $parm, $print_line, $split_val, $delta) = @_;

1910

if (!defined $self->{v}{$sect}{$parm}) {

1911

if ($delta) {

1912

$print_line->("$self->{comment_char} $parm is deleted");

1913

}

1914

else {

1915

warn "Weird unknown parameter $parm" if $^W;

1916

}

1917

return;

1918

}

1919

1920

$self->_output_comments($print_line, $self->{pCMT}{$sect}{$parm});

1921

1922

my $val = $self->{v}{$sect}{$parm};

1923

my $end_comment = $self->{peCMT}{$sect}{$parm};

1924

1925

return if ! defined ($val); # No parameter exists !!

1926

1927

$self->_OutputParam(

1928

$sect,

1929

$parm,

1930

$split_val->($val),

1931

(defined($end_comment) ? $end_comment : ""),

1932

$print_line,

1933

);

1934

1935

return;

1936

}

1937

1938

sub _output_section {

1939

my ($self, $sect, $print_line, $split_val, $delta, $position) = @_;

1940

1941

if (!defined $self->{v}{$sect}) {

1942

if ($delta) {

1943

$print_line->("$self->{comment_char} [$sect] is deleted");

1944

} else {

1945

warn "Weird unknown section $sect" if $^W;

1946

}

1947

return;

1948

}

1949

return if not defined $self->{v}{$sect};

1950

$print_line->() if ($position > 0);

1951

$self->_output_comments($print_line, $self->{sCMT}{$sect});

1952

1953

if (!

1954

($self->{fallback_used} and $sect eq $self->{fallback})

1955

)

1956

{

1957

$print_line->("[$sect]");

1958

}

1959

return if ref($self->{v}{$sect}) ne 'HASH';

1960

1961

foreach my $parm (@{$self->{$delta ? "myparms" : "parms"}{$sect}}) {

1962

$self->_output_param_total(

1963

$sect, $parm, $print_line, $split_val, $delta

1964

);

1965

}

1966

1967

return;

1968

}

1969

1970

sub OutputConfigToFileHandle {

1971

# We need no strict 'refs' to be able to print to $fh if it points

1972

# to a glob filehandle.

1973

no strict 'refs';

1974

my ($self, $fh, $delta) = @_;

1975

1976

my $ors = $self->{line_ends} || $\ || "\n"; # $\ is normally unset, but use input by default

1977

my $print_line = sub { print {$fh} (@_, $ors); };

1978

my $split_val = sub {

1979

my ($val) = @_;

1980

1981

return ((ref($val) eq 'ARRAY')

1982

? $val

1983

: [split /[$ors]/, $val, -1]

1984

);

1985

};

1986

1987

my $position = 0;

1988

1989

foreach my $sect (@{$self->{$delta ? "mysects" : "sects"}}) {

1990

$self->_output_section(

1991

$sect, $print_line, $split_val, $delta, $position++

1992

);

1993

}

1994

1995

$self->_output_comments($print_line, [ $self->_GetEndComments() ] );

1996

1997

return 1;

1998

}

1999

2000

=head2 SetSectionComment($section, @comment)

2001

2002

Sets the comment for section $section to the lines contained in @comment.

2003

2004

Each comment line will be prepended with the comment character (default

2005

is C<#>) if it doesn't already have a comment character (ie: if the

2006

line does not start with whitespace followed by an allowed comment

2007

character, default is C<#> and C<;>).

2008

2009

To clear a section comment, use DeleteSectionComment ($section)

2010

2011

=cut

2012

2013

sub SetSectionComment

2014

{

2015

my ($self, $sect, @comment) = @_;

2016

2017

if (not (defined($sect) && @comment))

2018

{

2019

return undef;

2020

}

2021

2022

$self->_caseify(\$sect);

2023

2024

$self->_touch_section($sect);

2025

# At this point it's possible to have a comment for a section that

2026

# doesn't exist. This comment will not get written to the INI file.

2027

$self->{sCMT}{$sect} = $self->_markup_comments(\@comment);

2028

2029

return scalar @comment;

2030

}

2031

2032

2033

2034

# this helper makes sure that each line is preceded with the correct comment

2035

# character

2036

sub _markup_comments

2037

{

2038

my ($self, $comment_aref) = @_;

2039

2040

my $allCmt = $self->{allowed_comment_char};

2041

my $cmtChr = $self->{comment_char};

2042

2043

my $is_comment = qr/\A\s*[$allCmt]/;

2044

2045

# TODO : Maybe create a qr// out of it.

2046

return [map { ($_ =~ $is_comment) ? $_ : "$cmtChr $_" } @$comment_aref];

2047

}

2048

2049

2050

2051

=head2 GetSectionComment ($section)

2052

2053

Returns a list of lines, being the comment attached to section $section. In

2054

scalar context, returns a string containing the lines of the comment separated

2055

by newlines.

2056

2057

The lines are presented as-is, with whatever comment character was originally

2058

used on that line.

2059

2060

=cut

2061

2062

sub _return_comment

2063

{

2064

my ($self, $comment_aref) = @_;

2065

2066

my $delim = defined($/) ? $/ : "\n";

2067

2068

return wantarray() ? @$comment_aref : join($delim, @$comment_aref);

2069

}

2070

2071

sub GetSectionComment

2072

{

2073

my ($self, $sect) = @_;

2074

2075

return undef if not defined $sect;

2076

2077

$self->_caseify(\$sect);

2078

2079

if (! exists $self->{sCMT}{$sect}) {

2080

return undef;

2081

}

2082

2083

return $self->_return_comment( $self->{sCMT}{$sect} );

2084

}

2085

2086

=head2 DeleteSectionComment ($section)

2087

2088

Removes the comment for the specified section.

2089

2090

=cut

2091

2092

sub DeleteSectionComment

2093

{

2094

my $self = shift;

2095

my $sect = shift;

2096

2097

return undef if not defined $sect;

2098

2099

$self->_caseify(\$sect);

2100

$self->_touch_section($sect);

2101

2102

delete $self->{sCMT}{$sect};

2103

2104

return;

2105

}

2106

2107

=head2 SetParameterComment ($section, $parameter, @comment)

2108

2109

Sets the comment attached to a particular parameter.

2110

2111

Any line of @comment that does not have a comment character will be

2112

prepended with one. See L</SetSectionComment($section, @comment)> above

2113

2114

=cut

2115

2116

sub SetParameterComment

2117

{

2118

my ($self, $sect, $parm, @comment) = @_;

2119

2120

if (not (defined($sect) && defined($parm) && @comment))

2121

{

2122

return undef;

2123

}

2124

2125

$self->_caseify(\$sect, \$parm);

2126

2127

$self->_touch_parameter($sect, $parm);

2128

2129

# Note that at this point, it's possible to have a comment for a parameter,

2130

# without that parameter actually existing in the INI file.

2131

$self->{pCMT}{$sect}{$parm} = $self->_markup_comments(\@comment);

2132

2133

return scalar @comment;

2134

}

2135

2136

sub _SetEndComments

2137

{

2138

my $self = shift;

2139

my @comments = @_;

2140

2141

$self->{_comments_at_end_of_file} = \@comments;

2142

2143

return 1;

2144

}

2145

2146

sub _GetEndComments {

2147

my $self = shift;

2148

2149

return @{$self->{_comments_at_end_of_file}};

2150

}

2151

2152

=head2 GetParameterComment ($section, $parameter)

2153

2154

Gets the comment attached to a parameter. In list context returns all

2155

comments - in scalar context returns them joined by newlines.

2156

2157

=cut

2158

2159

sub GetParameterComment

2160

{

2161

my ($self, $sect, $parm) = @_;

2162

2163

if (not (defined($sect) && defined($parm)))

2164

{

2165

return undef;

2166

}

2167

2168

$self->_caseify(\$sect, \$parm);

2169

2170

if (not (exists( $self->{pCMT}{$sect} )

2171

&& exists( $self->{pCMT}{$sect}{$parm} )))

2172

{

2173

return undef;

2174

}

2175

2176

return $self->_return_comment( $self->{pCMT}{$sect}{$parm} );

2177

}

2178

2179

=head2 DeleteParameterComment ($section, $parmeter)

2180

2181

Deletes the comment attached to a parameter.

2182

2183

=cut

2184

2185

sub DeleteParameterComment

2186

{

2187

my ($self, $sect, $parm) = @_;

2188

2189

if (not (defined($sect) && defined($parm)))

2190

{

2191

return undef;

2192

}

2193

2194

$self->_caseify(\$sect, \$parm);

2195

2196

# If the parameter doesn't exist, our goal has already been achieved

2197

if ( exists( $self->{pCMT}{$sect} )

2198

&& exists( $self->{pCMT}{$sect}{$parm} ))

2199

{

2200

$self->_touch_parameter($sect, $parm);

2201

delete $self->{pCMT}{$sect}{$parm};

2202

}

2203

2204

return 1;

2205

}

2206

2207

=head2 GetParameterEOT ($section, $parameter)

2208

2209

Accessor method for the EOT text (in fact, style) of the specified parameter. If any text is used as an EOT mark, this will be returned. If the parameter was not recorded using HERE style multiple lines, GetParameterEOT returns undef.

2210

2211

=cut

2212

2213

sub GetParameterEOT

2214

{

2215

my ($self, $sect, $parm) = @_;

2216

2217

if (not (defined($sect) && defined($parm)))

2218

{

2219

return undef;

2220

}

2221

2222

$self->_caseify(\$sect, \$parm);

2223

2224

return $self->{EOT}{$sect}{$parm};

2225

}

2226

2227

=head2 $cfg->SetParameterEOT ($section, $parameter, $EOT)

2228

2229

Accessor method for the EOT text for the specified parameter. Sets the HERE style marker text to the value $EOT. Once the EOT text is set, that parameter will be saved in HERE style.

2230

2231

To un-set the EOT text, use DeleteParameterEOT ($section, $parameter).

2232

2233

=cut

2234

2235

sub SetParameterEOT

2236

{

2237

my ($self, $sect, $parm, $EOT) = @_;

2238

2239

if (not (defined($sect) && defined($parm) && defined($EOT)))

2240

{

2241

return undef;

2242

}

2243

2244

$self->_caseify(\$sect, \$parm);

2245

2246

$self->_touch_parameter($sect, $parm);

2247

2248

$self->{EOT}{$sect}{$parm} = $EOT;

2249

2250

return;

2251

}

2252

2253

=head2 DeleteParameterEOT ($section, $parmeter)

2254

2255

Removes the EOT marker for the given section and parameter.

2256

When writing a configuration file, if no EOT marker is defined

2257

then "EOT" is used.

2258

2259

=cut

2260

2261

sub DeleteParameterEOT

2262

{

2263

my ($self, $sect, $parm) = @_;

2264

2265

if (not (defined($sect) && defined($parm)))

2266

{

2267

return undef;

2268

}

2269

2270

$self->_caseify(\$sect, \$parm);

2271

2272

$self->_touch_parameter($sect, $parm);

2273

delete $self->{EOT}{$sect}{$parm};

2274

2275

return;

2276

}

2277

2278

=head2 SetParameterTrailingComment ($section, $parameter, $cmt)

2279

2280

Set the end trailing comment for the given section and parameter.

2281

If there is a old comment for the parameter, it will be

2282

overwritten by the new one.

2283

2284

If there is a new parameter trailing comment to be added, the

2285

value should be added first.

2286

2287

=cut

2288

2289

sub SetParameterTrailingComment

2290

{

2291

my ($self, $sect, $parm, $cmt) = @_;

2292

2293

if (not (defined($sect) && defined($parm) && defined($cmt)))

2294

{

2295

return undef;

2296

}

2297

2298

$self->_caseify(\$sect, \$parm);

2299

2300

# confirm the parameter exist

2301

return undef if not exists $self->{v}{$sect}{$parm};

2302

2303

$self->_touch_parameter($sect, $parm);

2304

$self->{peCMT}{$sect}{$parm} = $cmt;

2305

2306

return 1;

2307

}

2308

2309

=head2 GetParameterTrailingComment ($section, $parameter)

2310

2311

An accessor method to read the trailing comment after the parameter.

2312

The trailing comment will be returned if there is one. A null string

2313

will be returned if the parameter exists but no comment for it.

2314

otherwise, L<undef> will be returned.

2315

2316

=cut

2317

2318

sub GetParameterTrailingComment

2319

{

2320

my ($self, $sect, $parm) = @_;

2321

2322

if (not (defined($sect) && defined($parm)))

2323

{

2324

return undef;

2325

}

2326

2327

$self->_caseify(\$sect, \$parm);

2328

2329

# confirm the parameter exist

2330

return undef if not exists $self->{v}{$sect}{$parm};

2331

return $self->{peCMT}{$sect}{$parm};

2332

}

2333

2334

=head2 Delete

2335

2336

Deletes the entire configuration file in memory.

2337

2338

=cut

2339

2340

sub Delete {

2341

my $self = shift;

2342

2343

foreach my $section ($self->Sections()) {

2344

$self->DeleteSection($section);

2345

}

2346

2347

return 1;

2348

} # end Delete

2349

2350

2351

2352

=head1 USAGE -- Tied Hash

2353

2354

=head2 tie %ini, 'Config::IniFiles', (-file=>$filename, [-option=>value ...] )

2355

2356

Using C<tie>, you can tie a hash to a B<Config::IniFiles> object. This creates a new

2357

object which you can access through your hash, so you use this instead of the

2358

B<new> method. This actually creates a hash of hashes to access the values in

2359

the INI file. The options you provide through C<tie> are the same as given for

2360

the B<new> method, above.

2361

2362

Here's an example:

2363

2364

use Config::IniFiles;

2365

2366

my %ini

2367

tie %ini, 'Config::IniFiles', ( -file => "/path/configfile.ini" );

2368

2369

print "We have $ini{Section}{Parameter}." if $ini{Section}{Parameter};

2370

2371

Accessing and using the hash works just like accessing a regular hash and

2372

many of the object methods are made available through the hash interface.

2373

2374

For those methods that do not coincide with the hash paradigm, you can use

2375

the Perl C<tied> function to get at the underlying object tied to the hash

2376

and call methods on that object. For example, to write the hash out to a new

2377

ini file, you would do something like this:

2378

2379

tied( %ini )->WriteConfig( "/newpath/newconfig.ini" ) ||

2380

die "Could not write settings to new file.";

2381

2382

=head2 $val = $ini{$section}{$parameter}

2383

2384

Returns the value of $parameter in $section.

2385

2386

Multiline values accessed through a hash will be returned

2387

as a list in list context and a concatenated value in scalar

2388

context.

2389

2390

=head2 $ini{$section}{$parameter} = $value;

2391

2392

Sets the value of C<$parameter> in C<$section> to C<$value>.

2393

2394

To set a multiline or multiv-alue parameter just assign an

2395

array reference to the hash entry, like this:

2396

2397

$ini{$section}{$parameter} = [$value1, $value2, ...];

2398

2399

If the parameter did not exist in the original file, it will

2400

be created. However, Perl does not seem to extend autovivification

2401

to tied hashes. That means that if you try to say

2402

2403

$ini{new_section}{new_paramters} = $val;

2404

2405

and the section 'new_section' does not exist, then Perl won't

2406

properly create it. In order to work around this you will need

2407

to create a hash reference in that section and then assign the

2408

parameter value. Something like this should do nicely:

2409

2410

$ini{new_section} = {};

2411

$ini{new_section}{new_paramters} = $val;

2412

2413

=head2 %hash = %{$ini{$section}}

2414

2415

Using the tie interface, you can copy whole sections of the

2416

ini file into another hash. Note that this makes a copy of

2417

the entire section. The new hash in no longer tied to the

2418

ini file, In particular, this means -default and -nocase

2419

settings will not apply to C<%hash>.

2420

2421

2422

=head2 $ini{$section} = {}; %{$ini{$section}} = %parameters;

2423

2424

Through the hash interface, you have the ability to replace

2425

the entire section with a new set of parameters. This call

2426

will fail, however, if the argument passed in NOT a hash

2427

reference. You must use both lines, as shown above so that

2428

Perl recognizes the section as a hash reference context

2429

before COPYing over the values from your C<%parameters> hash.

2430

2431

=head2 delete $ini{$section}{$parameter}

2432

2433

When tied to a hash, you can use the Perl C<delete> function

2434

to completely remove a parameter from a section.

2435

2436

=head2 delete $ini{$section}

2437

2438

The tied interface also allows you to delete an entire

2439

section from the ini file using the Perl C<delete> function.

2440

2441

=head2 %ini = ();

2442

2443

If you really want to delete B<all> the items in the ini file, this

2444

will do it. Of course, the changes won't be written to the actual

2445

file unless you call B<RewriteConfig> on the object tied to the hash.

2446

2447

=head2 Parameter names

2448

2449

=over 4

2450

2451

=item my @keys = keys %{$ini{$section}}

2452

2453

=item while (($k, $v) = each %{$ini{$section}}) {...}

2454

2455

=item if( exists %{$ini{$section}}, $parameter ) {...}

2456

2457

=back

2458

2459

When tied to a hash, you use the Perl C<keys> and C<each>

2460

functions to iteratively list the parameters (C<keys>) or

2461

parameters and their values (C<each>) in a given section.

2462

2463

You can also use the Perl C<exists> function to see if a

2464

parameter is defined in a given section.

2465

2466

Note that none of these will return parameter names that

2467

are part of the default section (if set), although accessing

2468

an unknown parameter in the specified section will return a

2469

value from the default section if there is one.

2470

2471

2472

=head2 Section names

2473

2474

=over 4

2475

2476

=item foreach( keys %ini ) {...}

2477

2478

=item while (($k, $v) = each %ini) {...}

2479

2480

=item if( exists %ini, $section ) {...}

2481

2482

=back

2483

2484

When tied to a hash, you use the Perl C<keys> and C<each>

2485

functions to iteratively list the sections in the ini file.

2486

2487

You can also use the Perl C<exists> function to see if a

2488

section is defined in the file.

2489

2490

=cut

2491

2492

############################################################

2493

#

2494

# TIEHASH Methods

2495

#

2496

# Description:

2497

# These methods allow you to tie a hash to the

2498

# Config::IniFiles object. Note that, when tied, the

2499

# user wants to look at thinks like $ini{sec}{parm}, but the

2500

# TIEHASH only provides one level of hash interace, so the

2501

# root object gets asked for a $ini{sec}, which this

2502

# implements. To further tie the {parm} hash, the internal

2503

# class Config::IniFiles::_section, is provided, below.

2504

#

2505

############################################################

2506

# ----------------------------------------------------------

2507

# Date Modification Author

2508

# ----------------------------------------------------------

2509

# 2000May09 Created method JW

2510

# ----------------------------------------------------------

2511

sub TIEHASH {

2512

my $class = shift;

2513

my %parms = @_;

2514

2515

# Get a new object

2516

my $self = $class->new( %parms );

2517

2518

return $self;

2519

} # end TIEHASH

2520

2521

2522

# ----------------------------------------------------------

2523

# Date Modification Author

2524

# ----------------------------------------------------------

2525

# 2000May09 Created method JW

2526

# ----------------------------------------------------------

2527

sub FETCH {

2528

my $self = shift;

2529

my( $key ) = @_;

2530

2531

$self->_caseify(\$key);

2532

return if (! $self->{v}{$key});

2533

2534

my %retval;

2535

tie %retval, 'Config::IniFiles::_section', $self, $key;

2536

return \%retval;

2537

2538

} # end FETCH

2539

2540

# ----------------------------------------------------------

2541

# Date Modification Author

2542

# ----------------------------------------------------------

2543

# 2000Jun14 Fixed bug where wrong ref was saved JW

2544

# 2000Oct09 Fixed possible but in %parms with defaults JW

2545

# 2001Apr04 Fixed -nocase problem in storing JW

2546

# ----------------------------------------------------------

2547

sub STORE {

2548

my $self = shift;

2549

my( $key, $ref ) = @_;

2550

2551

return undef unless ref($ref) eq 'HASH';

2552

2553

$self->_caseify(\$key);

2554

2555

$self->AddSection($key);

2556

$self->{v}{$key} = {%$ref};

2557

$self->{parms}{$key} = [keys %$ref];

2558

$self->{myparms}{$key} = [keys %$ref];

2559

2560

return 1;

2561

} # end STORE

2562

2563

2564

# ----------------------------------------------------------

2565

# Date Modification Author

2566

# ----------------------------------------------------------

2567

# 2000May09 Created method JW

2568

# 2000Dec17 Now removes comments, groups and EOTs too JW

2569

# 2001Arp04 Fixed -nocase problem JW

2570

# ----------------------------------------------------------

2571

sub DELETE {

2572

my $self = shift;

2573

my( $key ) = @_;

2574

2575

my $retval=$self->FETCH($key);

2576

$self->DeleteSection($key);

2577

return $retval;

2578

} # end DELETE

2579

2580

2581

# ----------------------------------------------------------

2582

# Date Modification Author

2583

# ----------------------------------------------------------

2584

# 2000May09 Created method JW

2585

# ----------------------------------------------------------

2586

sub CLEAR {

2587

my $self = shift;

2588

2589

return $self->Delete();

2590

} # end CLEAR

2591

2592

# ----------------------------------------------------------

2593

# Date Modification Author

2594

# ----------------------------------------------------------

2595

# 2000May09 Created method JW

2596

# ----------------------------------------------------------

2597

sub FIRSTKEY {

2598

my $self = shift;

2599

2600

$self->{tied_enumerator}=0;

2601

return $self->NEXTKEY();

2602

} # end FIRSTKEY

2603

2604

2605

# ----------------------------------------------------------

2606

# Date Modification Author

2607

# ----------------------------------------------------------

2608

# 2000May09 Created method JW

2609

# ----------------------------------------------------------

2610

sub NEXTKEY {

2611

my $self = shift;

2612

my( $last ) = @_;

2613

2614

my $i=$self->{tied_enumerator}++;

2615

my $key=$self->{sects}[$i];

2616

return if (! defined $key);

2617

return wantarray ? ($key, $self->FETCH($key)) : $key;

2618

} # end NEXTKEY

2619

2620

2621

# ----------------------------------------------------------

2622

# Date Modification Author

2623

# ----------------------------------------------------------

2624

# 2000May09 Created method JW

2625

# 2001Apr04 Fixed -nocase bug and false true bug JW

2626

# ----------------------------------------------------------

2627

sub EXISTS {

2628

my $self = shift;

2629

my( $key ) = @_;

2630

return $self->SectionExists($key);

2631

} # end EXISTS

2632

2633

2634

# ----------------------------------------------------------

2635

# DESTROY is used by TIEHASH and the Perl garbage collector,

2636

# ----------------------------------------------------------

2637

# Date Modification Author

2638

# ----------------------------------------------------------

2639

# 2000May09 Created method JW

2640

# ----------------------------------------------------------

2641

sub DESTROY {

2642

# my $self = shift;

2643

} # end if

2644

2645

2646

# ----------------------------------------------------------

2647

# Sub: _make_filehandle

2648

#

2649

# Args: $thing

2650

# $thing An input source

2651

#

2652

# Description: Takes an input source of a filehandle,

2653

# filehandle glob, reference to a filehandle glob, IO::File

2654

# object or scalar filename and returns a file handle to

2655

# read from it with.

2656

# ----------------------------------------------------------

2657

# Date Modification Author

2658

# ----------------------------------------------------------

2659

# 06Dec2001 Added to support input from any source JW

2660

# ----------------------------------------------------------

2661

sub _make_filehandle {

2662

my $self = shift;

2663

2664

#

2665

# This code is 'borrowed' from Lincoln D. Stein's GD.pm module

2666

# with modification for this module. Thanks Lincoln!

2667

#

2668

2669

no strict 'refs';

2670

my $thing = shift;

2671

2672

if (ref($thing) eq "SCALAR") {

2673

if (eval { require IO::Scalar; $IO::Scalar::VERSION >= 2.109; }) {

2674

return IO::Scalar->new($thing);

2675

} else {

2676

warn "SCALAR reference as file descriptor requires IO::stringy ".

2677

"v2.109 or later" if ($^W);

2678

return;

2679

}

2680

}

2681

2682

return $thing if defined(fileno $thing);

2683

2684

# otherwise try qualifying it into caller's package

2685

my $fh = qualify_to_ref($thing,caller(1));

2686

return $fh if defined(fileno $fh);

2687

2688

# otherwise treat it as a file to open

2689

$fh = gensym;

2690

open($fh,$thing) || return;

2691

2692

return $fh;

2693

} # end _make_filehandle

2694

2695

############################################################

2696

#

2697

# INTERNAL PACKAGE: Config::IniFiles::_section

2698

#

2699

# Description:

2700

# This package is used to provide a single-level TIEHASH

2701

# interface to the sections in the IniFile. When tied, the

2702

# user wants to look at thinks like $ini{sec}{parm}, but the

2703

# TIEHASH only provides one level of hash interace, so the

2704

# root object gets asked for a $ini{sec} and must return a

2705

# has reference that accurately covers the '{parm}' part.

2706

#

2707

# This package is only used when tied and is inter-woven

2708

# between the sections and their parameters when the TIEHASH

2709

# method is called by Perl. It's a very simple implementation

2710

# of a tied hash object that simply maps onto the object API.

2711

#

2712

############################################################

2713

# Date Modification Author

2714

# ----------------------------------------------------------

2715

# 2000.May.09 Created to excapsulate TIEHASH interface JW

2716

############################################################

2717

package Config::IniFiles::_section;

2718

2719

use strict;

2720

use warnings;

2721

use Carp;

2722

use vars qw( $VERSION );

2723

2724

$Config::IniFiles::_section::VERSION = 2.16;

2725

2726

# ----------------------------------------------------------

2727

# Sub: Config::IniFiles::_section::TIEHASH

2728

#

2729

# Args: $class, $config, $section

2730

# $class The class that this is being tied to.

2731

# $config The parent Config::IniFiles object

2732

# $section The section this tied object refers to

2733

#

2734

# Description: Builds the object that implements accesses to

2735

# the tied hash.

2736

# ----------------------------------------------------------

2737

# Date Modification Author

2738

# ----------------------------------------------------------

2739

# ----------------------------------------------------------

2740

sub TIEHASH {

2741

my $proto = shift;

2742

my $class = ref($proto) || $proto;

2743

my ($config, $section) = @_;

2744

2745

# Make a new object

2746

return bless {config=>$config, section=>$section}, $class;

2747

} # end TIEHASH

2748

2749

2750

# ----------------------------------------------------------

2751

# Sub: Config::IniFiles::_section::FETCH

2752

#

2753

# Args: $key

2754

# $key The name of the key whose value to get

2755

#

2756

# Description: Returns the value associated with $key. If

2757

# the value is a list, returns a list reference.

2758

# ----------------------------------------------------------

2759

# Date Modification Author

2760

# ----------------------------------------------------------

2761

# 2000Jun15 Fixed bugs in -default handler JW

2762

# 2000Dec07 Fixed another bug in -deault handler JW

2763

# 2002Jul04 Returning scalar values (Bug:447532) AS

2764

# ----------------------------------------------------------

2765

sub FETCH {

2766

my ($self, $key) = @_;

2767

my @retval=$self->{config}->val($self->{section}, $key);

2768

return (@retval <= 1) ? $retval[0] : \@retval;

2769

} # end FETCH

2770

2771

2772

# ----------------------------------------------------------

2773

# Sub: Config::IniFiles::_section::STORE

2774

#

2775

# Args: $key, @val

2776

# $key The key under which to store the value

2777

# @val The value to store, either an array or a scalar

2778

#

2779

# Description: Sets the value for the specified $key

2780

# ----------------------------------------------------------

2781

# Date Modification Author

2782

# ----------------------------------------------------------

2783

# 2001Apr04 Fixed -nocase bug JW

2784

# ----------------------------------------------------------

2785

sub STORE {

2786

my ($self, $key, @val) = @_;

2787

return $self->{config}->newval($self->{section}, $key, @val);

2788

} # end STORE

2789

2790

2791

# ----------------------------------------------------------

2792

# Sub: Config::IniFiles::_section::DELETE

2793

#

2794

# Args: $key

2795

# $key The key to remove from the hash

2796

#

2797

# Description: Removes the specified key from the hash and

2798

# returns its former value.

2799

# ----------------------------------------------------------

2800

# Date Modification Author

2801

# ----------------------------------------------------------

2802

# 2001Apr04 Fixed -nocase bug JW

2803

# ----------------------------------------------------------

2804

sub DELETE {

2805

my ($self, $key) = @_;

2806

my $retval=$self->{config}->val($self->{section}, $key);

2807

$self->{config}->delval($self->{section}, $key);

2808

return $retval;

2809

} # end DELETE

2810

2811

# ----------------------------------------------------------

2812

# Sub: Config::IniFiles::_section::CLEAR

2813

#

2814

# Args: (None)

2815

#

2816

# Description: Empties the entire hash

2817

# ----------------------------------------------------------

2818

# Date Modification Author

2819

# ----------------------------------------------------------

2820

# ----------------------------------------------------------

2821

sub CLEAR {

2822

my ($self) = @_;

2823

return $self->{config}->DeleteSection($self->{section});

2824

} # end CLEAR

2825

2826

# ----------------------------------------------------------

2827

# Sub: Config::IniFiles::_section::EXISTS

2828

#

2829

# Args: $key

2830

# $key The key to look for

2831

#

2832

# Description: Returns whether the key exists

2833

# ----------------------------------------------------------

2834

# Date Modification Author

2835

# ----------------------------------------------------------

2836

# 2001Apr04 Fixed -nocase bug JW

2837

# ----------------------------------------------------------

2838

sub EXISTS {

2839

my ($self, $key) = @_;

2840

return $self->{config}->exists($self->{section},$key);

2841

} # end EXISTS

2842

2843

# ----------------------------------------------------------

2844

# Sub: Config::IniFiles::_section::FIRSTKEY

2845

#

2846

# Args: (None)

2847

#

2848

# Description: Returns the first key in the hash

2849

# ----------------------------------------------------------

2850

# Date Modification Author

2851

# ----------------------------------------------------------

2852

# ----------------------------------------------------------

2853

sub FIRSTKEY {

2854

my $self = shift;

2855

2856

$self->{tied_enumerator}=0;

2857

return $self->NEXTKEY();

2858

} # end FIRSTKEY

2859

2860

# ----------------------------------------------------------

2861

# Sub: Config::IniFiles::_section::NEXTKEY

2862

#

2863

# Args: $last

2864

# $last The last key accessed by the interator

2865

#

2866

# Description: Returns the next key in line

2867

# ----------------------------------------------------------

2868

# Date Modification Author

2869

# ----------------------------------------------------------

2870

# ----------------------------------------------------------

2871

sub NEXTKEY {

2872

my $self = shift;

2873

my( $last ) = @_;

2874

2875

my $i=$self->{tied_enumerator}++;

2876

my @keys = $self->{config}->Parameters($self->{section});

2877

my $key=$keys[$i];

2878

return if (! defined $key);

2879

return wantarray ? ($key, $self->FETCH($key)) : $key;

2880

} # end NEXTKEY

2881

2882

2883

# ----------------------------------------------------------

2884

# Sub: Config::IniFiles::_section::DESTROY

2885

#

2886

# Args: (None)

2887

#

2888

# Description: Called on cleanup

2889

# ----------------------------------------------------------

2890

# Date Modification Author

2891

# ----------------------------------------------------------

2892

# ----------------------------------------------------------

2893

sub DESTROY {

2894

# my $self = shift

2895

} # end DESTROY

2896

2897

1;

2898

2899

=head1 IMPORT / DELTA FEATURES

2900

2901

The I<-import> option to L</new> allows one to stack one

2902

I<Config::IniFiles> object on top of another (which might be itself

2903

stacked in turn and so on recursively, but this is beyond the

2904

point). The effect, as briefly explained in L</new>, is that the

2905

fields appearing in the composite object will be a superposition of

2906

those coming from the ``original'' one and the lines coming from the

2907

file, the latter taking precedence. For example, let's say that

2908

C<$master> and C<overlay> were created like this:

2909

2910

my $master = Config::IniFiles->new(-file => "master.ini");

2911

my $overlay = Config::IniFiles->new(-file => "overlay.ini",

2912

-import => $master);

2913

2914

If the contents of C<master.ini> and C<overlay.ini> are respectively

2915

2916

; master.ini

2917

[section1]

2918

arg0=unchanged from master.ini

2919

arg1=val1

2920

2921

[section2]

2922

arg2=val2

2923

2924

and

2925

2926

; overlay.ini

2927

[section1]

2928

arg1=overriden

2929

2930

Then C<< $overlay->val("section1", "arg1") >> is "overriden", while

2931

C<< $overlay->val("section1", "arg0") >> is "unchanged from

2932

master.ini".

2933

2934

This feature may be used to ship a ``global defaults'' configuration

2935

file for a Perl application, that can be overridden piecewise by a

2936

much shorter, per-site configuration file. Assuming UNIX-style path

2937

names, this would be done like this:

2938

2939

my $defaultconfig = Config::IniFiles->new

2940

(-file => "/usr/share/myapp/myapp.ini.default");

2941

my $config = Config::IniFiles->new

2942

(-file => "/etc/myapp.ini", -import => $defaultconfig);

2943

# Now use $config and forget about $defaultconfig in the rest of

2944

# the program

2945

2946

Starting with version 2.39, I<Config::IniFiles> also provides features

2947

to keep the importing / per-site configuration file small, by only

2948

saving those options that were modified by the running program. That

2949

is, if one calls

2950

2951

$overlay->setval("section1", "arg1", "anotherval");

2952

$overlay->newval("section3", "arg3", "val3");

2953

$overlay->WriteConfig(-delta=>1);

2954

2955

C<overlay.ini> would now contain

2956

2957

; overlay.ini

2958

[section1]

2959

arg1=anotherval

2960

2961

[section3]

2962

arg3=val3

2963

2964

This is called a I<delta file> (see L</WriteConfig>). The untouched

2965

[section2] and arg0 do not appear, and the config file is therefore

2966

shorter; while of course, reloading the configuration into C<$master>

2967

and C<$overlay>, either through C<< $overlay->ReadConfig() >> or through

2968

the same code as above (e.g. when application restarts), would yield

2969

exactly the same result had the overlay object been saved in whole to

2970

the file system.

2971

2972

The only problem with this delta technique is one cannot delete the

2973

default values in the overlay configuration file, only change

2974

them. This is solved by a file format extension, enabled by the

2975

I<-negativedeltas> option to L</new>: if, say, one would delete

2976

parameters like this,

2977

2978

$overlay->DeleteSection("section2");

2979

$overlay->delval("section1", "arg0");

2980

$overlay->WriteConfig(-delta=>1);

2981

2982

The I<overlay.ini> file would now read:

2983

2984

; overlay.ini

2985

[section1]

2986

; arg0 is deleted

2987

arg1=anotherval

2988

2989

; [section2] is deleted

2990

2991

[section3]

2992

arg3=val3

2993

2994

Assuming C<$overlay> was later re-read with C<< -negativedeltas => 1 >>,

2995

the parser would interpret the deletion comments to yield the correct

2996

result, that is, [section2] and arg0 would cease to exist in the

2997

C<$overlay> object.

2998

2999

=cut

3000

3001

3002

=head1 DIAGNOSTICS

3003

3004

=head2 @Config::IniFiles::errors

3005

3006

Contains a list of errors encountered while parsing the configuration

3007

file. If the I<new> method returns B<undef>, check the value of this

3008

to find out what's wrong. This value is reset each time a config file

3009

is read.

3010

3011

=head1 BUGS

3012

3013

=over 3

3014

3015

=item *

3016

3017

The output from [Re]WriteConfig/OutputConfig might not be as pretty as

3018

it can be. Comments are tied to whatever was immediately below them.

3019

And case is not preserved for Section and Parameter names if the -nocase

3020

option was used.

3021

3022

=item *

3023

3024

No locking is done by [Re]WriteConfig. When writing servers, take

3025

care that only the parent ever calls this, and consider making your

3026

own backup.

3027

3028

=back

3029

3030

=head1 Data Structure

3031

3032

Note that this is only a reference for the package maintainers - one of the

3033

upcoming revisions to this package will include a total clean up of the

3034

data structure.

3035

3036

$iniconf->{cf} = "config_file_name"

3037

->{startup_settings} = \%orginal_object_parameters

3038

->{firstload} = 0 OR 1

3039

->{imported} = $object WHERE $object->isa("Config::IniFiles")

3040

->{nocase} = 0

3041

->{reloadwarn} = 0

3042

->{sects} = \@sections

3043

->{mysects} = \@sections

3044

->{sCMT}{$sect} = \@comment_lines

3045

->{group}{$group} = \@group_members

3046

->{parms}{$sect} = \@section_parms

3047

->{myparms}{$sect} = \@section_parms

3048

->{EOT}{$sect}{$parm} = "end of text string"

3049

->{pCMT}{$sect}{$parm} = \@comment_lines

3050

->{v}{$sect}{$parm} = $value OR \@values

3051

3052

=head1 AUTHOR and ACKNOWLEDGEMENTS

3053

3054

The original code was written by Scott Hutton.

3055

Then handled for a time by Rich Bowen (thanks!),

3056

and was later managed by Jeremy Wadsack (thanks!),

3057

and now is managed by Shlomi Fish ( L<http://www.shlomifish.org/> )

3058

with many contributions from various other people.

3059

3060

In particular, special thanks go to (in roughly chronological order):

3061

3062

Bernie Cosell, Alan Young, Alex Satrapa, Mike Blazer, Wilbert van de Pieterman,

3063

Steve Campbell, Robert Konigsberg, Scott Dellinger, R. Bernstein,

3064

Daniel Winkelmann, Pires Claudio, Adrian Phillips,

3065

Marek Rouchal, Luc St Louis, Adam Fischler, Kay R�pke, Matt Wilson,

3066

Raviraj Murdeshwar and Slaven Rezic, Florian Pfaff

3067

3068

Geez, that's a lot of people. And apologies to the folks who were missed.

3069

3070

If you want someone to bug about this, that would be:

3071

3072

Shlomi Fish <shlomif@cpan.org>

3073

3074

If you want more information, or want to participate, go to:

3075

3076

L<http://sourceforge.net/projects/config-inifiles/>

3077

3078

Please submit bug reports using the Request Tracker interface at

3079

L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IniFiles> .

3080

3081

Development discussion occurs on the mailing list

3082

config-inifiles-dev@lists.sourceforge.net, which you can subscribe

3083

to by going to the project web site (link above).

3084

3085

This program is free software; you can redistribute it and/or

3086

modify it under the same terms as Perl itself.

3087

3088

=cut

3089

3090

1;

3091

3092

# Please keep the following within the last four lines of the file

3093

#[JW for editor]:mode=perl:tabSize=8:indentSize=2:noTabs=true:indentOnEnter=true:

3094

			@@ -0,0 +1,8
		1	set QTDIR=%1
		2	set PATH=%1\bin;
		3	set PATH=%PATH%;%3
		4	set PATH=%PATH%;%SystemRoot%\System32
		5	set QMAKESPEC=win32-g++
		6	qmake -r charts.pro CONFIG+=%2
		7	@echo on
		8	mingw32-make No newline at end of file

			@@ -0,0 +1,10
		1	set QTDIR=%1
		2	set PATH=%1\bin;%PATH%;
		3	set QMAKESPEC=win32-msvc2005
		4	call "C:\Program Files (x86)\Microsoft Visual Studio 8\VC\vcvarsall.bat" x86
		5	@echo on
		6	set INCLUDE=%INCLUDE%;C:\Program Files (x86)\Microsoft SDKs\Windows\v7.0A\Include
		7	set LIB=%LIB%;C:\Program Files (x86)\Microsoft SDKs\Windows\v7.0A\Lib
		8	qmake -r charts.pro CONFIG+=%2
		9	@echo on
		10	nmake

			@@ -0,0 +1,8
		1	set QTDIR=%1
		2	set PATH=%1\bin;%PATH%;
		3	set QMAKESPEC=win32-msvc2008
		4	call "C:\Program Files (x86)\Microsoft Visual Studio 9.0\VC\vcvarsall.bat" x86
		5	@echo on
		6	qmake -r charts.pro CONFIG+=%2
		7	@echo on
		8	nmake

			@@ -0,0 +1,8
		1	set QTDIR=%1
		2	set PATH=%1\bin;%PATH%;
		3	set QMAKESPEC=win32-msvc2010
		4	call "C:\Program Files (x86)\Microsoft Visual Studio 10.0\VC\vcvarsall.bat" x86
		5	@echo on
		6	qmake -r charts.pro CONFIG+=%2
		7	@echo on
		8	nmake

			@@ -0,0 +1,50
		1
		2	[Win7 MinGW debug QtC v4.8.0 (Jani's machine)]
		3	Platform=Win7
		4	QtDir=D:\Qt\4.8.0-MinGW-Commercial
		5	ToolChain=mingw
		6	Config=debug
		7	MinGWDir=D:\Qt\mingw\bin
		8
		9	[Win7 MinGW release QtC v4.8.0 (Jani's machine)]
		10	Platform=Win7
		11	QtDir=D:\Qt\4.8.0-MinGW-Commercial
		12	ToolChain=mingw
		13	Config=release
		14	MinGWDir=D:\Qt\mingw\bin
		15
		16	[Win7 vs2005 debug QtC v4.7.5 (Jani's machine)]
		17	Platform=Win7
		18	QtDir=D:\Qt\qt-win-commercial-4.7.5-vs2005
		19	ToolChain=vs2005
		20	Config=debug
		21
		22	[Win7 vs2005 release QtC v4.7.5 (Jani's machine)]
		23	Platform=Win7
		24	QtDir=D:\Qt\qt-win-commercial-4.7.5-vs2005
		25	ToolChain=vs2005
		26	Config=release
		27
		28	[Win7 vs2008 debug QtC v4.8.2 (Jani's machine)]
		29	Platform=Win7
		30	QtDir=D:\Qt\qt-win-commercial-4.8.2-vs2008-15-Apr-2012
		31	ToolChain=vs2008
		32	Config=debug
		33
		34	[Win7 vs2008 release QtC v4.8.2 (Jani's machine)]
		35	Platform=Win7
		36	QtDir=D:\Qt\qt-win-commercial-4.8.2-vs2008-15-Apr-2012
		37	ToolChain=vs2008
		38	Config=release
		39
		40	[Win7 vs2010 debug QtC v4.8.0 (Jani's machine)]
		41	Platform=Win7
		42	QtDir=D:\Qt\qt-win-commercial-4.8.0-vs2010
		43	ToolChain=vs2010
		44	Config=debug
		45
		46	[Win7 vs2010 release QtC v4.8.0 (Jani's machine)]
		47	Platform=Win7
		48	QtDir=D:\Qt\qt-win-commercial-4.8.0-vs2010
		49	ToolChain=vs2010
		50	Config=release No newline at end of file

			@@ -0,0 +1,48
		1	use lib 'test/scripts'; # for IniFiles
		2	use File::Basename;
		3	use IniFiles;
		4	use feature "switch";
		5
		6	# read command line params
		7	my $jobname = shift;
		8
		9	# read ini file
		10	my $scriptdir = File::Basename::dirname($0);
		11	my $inifile = $scriptdir . "/jobs.ini";
		12	my %cfg;
		13	tie %cfg, 'Config::IniFiles', ( -file => $inifile );
		14
		15	# get section from ini by jobname
		16	my %build = %{$cfg{$jobname}};
		17
		18	# print out the ini settings
		19	print "\n\n$jobname\n";
		20	print "**********\n";
		21	foreach (keys %build) {
		22	print $_ . " : " . $build{$_} . "\n";
		23	}
		24
		25	# examine the platform
		26	given ($build{'Platform'}) {
		27	when ("Win7") {
		28	# construct a build command
		29	my @cmd;
		30	if ($build{'ToolChain'} eq "mingw") {
		31	@cmd = ($scriptdir . "\\build_win_mingw.bat", $build{'QtDir'}, $build{'Config'}, $build{'MinGWDir'});
		32	}
		33	if ($build{'ToolChain'} eq "vs2005") {
		34	@cmd = ($scriptdir . "\\build_win_vs2005.bat", $build{'QtDir'}, $build{'Config'});
		35	}
		36	if ($build{'ToolChain'} eq "vs2008") {
		37	@cmd = ($scriptdir . "\\build_win_vs2008.bat", $build{'QtDir'}, $build{'Config'});
		38	}
		39	if ($build{'ToolChain'} eq "vs2010") {
		40	@cmd = ($scriptdir . "\\build_win_vs2010.bat", $build{'QtDir'}, $build{'Config'});
		41	}
		42	# run the build command
		43	system (@cmd) == 0 or die "system @cmd failed: $?";
		44	}
		45	default {
		46	die "Unknown platform " . $build{'Platform'};
		47	}
		48	} No newline at end of file

	Site-wide shortcuts
/	Use quick search box
g h	Goto home page
g g	Goto my private gists page
g G	Goto my public gists page
g 0-9	Goto bookmarked items from 0-9
n r	New repository page
n g	New gist page

	Repositories
g s	Goto summary page
g c	Goto changelog page
g f	Goto files page
g F	Goto files page with file search activated
g p	Goto pull requests page
g o	Goto repository settings
g O	Goto repository access permissions settings
t s	Toggle sidebar on some pages