File Coverage

blib/lib/Config/IniFiles.pm

Criterion	Covered	Total	%
statement	804	885	90.8
branch	301	398	75.6
condition	64	117	54.7
subroutine	117	127	92.1
pod	39	39	100.0
total	1325	1566	84.6

package Config::IniFiles;

require 5.008;
use strict;
use warnings;

our $VERSION = '3.000003';
use Carp;
use Symbol 'gensym', 'qualify_to_ref';    # For the 'any data type' hack
use Fcntl qw( SEEK_SET SEEK_CUR );

use List::Util 1.33 qw(any none);

use File::Basename qw( dirname );
use File::Temp qw/ tempfile /;

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

#   $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 $


sub _nocase
{
    my $self = shift;

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

    return $self->{nocase};
}

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

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

sub new
{
    my $class = shift;
    my %parms = @_;

    my $errs   = 0;
    my @groups = ();

    my $self = bless {
        default                 => '',
        fallback                => undef,
        fallback_used           => 0,
        imported                => undef,
        v                       => {},
        cf                      => undef,
        nomultiline             => 0,
        handle_trailing_comment => 0,
    }, $class;

    if ( ref( $parms{-import} )
        && ( $parms{-import}->isa('Config::IniFiles') ) )
    {
        $self->{imported} = $parms{-import};    # ReadConfig will load the data
        $self->{negativedeltas} = 1;
    }
    elsif ( defined $parms{-import} )
    {
        carp "Invalid -import value \"$parms{-import}\" was ignored.";
    }    # end if
    delete $parms{-import};

    # Copy the original parameters so we
    # can use them when we build new sections
    %{ $self->{startup_settings} } = %parms;

    # Parse options
    my ( $k, $v );
    $self->_nocase(0);

    # Handle known parameters first in this order,
    # because each() could return parameters in any order
    if ( defined( $v = delete $parms{'-file'} ) )
    {
        # Should we be pedantic and check that the file exists?
        # .. no, because now it could be a handle, IO:: object or something else
        $self->{cf} = $v;
    }
    if ( defined( $v = delete $parms{'-nocase'} ) )
    {
        $self->_nocase($v);
    }
    if ( defined( $v = delete $parms{'-default'} ) )
    {
        $self->{default} = $self->_nocase ? lc($v) : $v;
    }
    if ( defined( $v = delete $parms{'-fallback'} ) )
    {
        $self->{fallback} = $self->_nocase ? lc($v) : $v;
    }
    if ( defined( $v = delete $parms{'-reloadwarn'} ) )
    {
        $self->{reloadwarn} = $v ? 1 : 0;
    }
    if ( defined( $v = delete $parms{'-nomultiline'} ) )
    {
        $self->{nomultiline} = $v ? 1 : 0;
    }
    if ( defined( $v = delete $parms{'-allowcontinue'} ) )
    {
        $self->{allowcontinue} = $v ? 1 : 0;
    }
    if ( defined( $v = delete $parms{'-allowempty'} ) )
    {
        $self->{allowempty} = $v ? 1 : 0;
    }
    if ( defined( $v = delete $parms{'-negativedeltas'} ) )
    {
        $self->{negativedeltas} = $v ? 1 : 0;
    }
    if ( defined( $v = delete $parms{'-commentchar'} ) )
    {
        if ( !defined $v || length($v) != 1 )
        {
            carp "Comment character must be unique.";
            $errs++;
        }
        elsif ( $v =~ /[\[\]=\w]/ )
        {
            # must not be square bracket, equal sign or alphanumeric
            carp "Illegal comment character.";
            $errs++;
        }
        else
        {
            $self->{comment_char} = $v;
        }
    }
    if ( defined( $v = delete $parms{'-allowedcommentchars'} ) )
    {
        # must not be square bracket, equal sign or alphanumeric
        if ( !defined $v || $v =~ /[\[\]=\w]/ )
        {
            carp "Illegal value for -allowedcommentchars.";
            $errs++;
        }
        else
        {
            $self->{allowed_comment_char} = $v;
        }
    }

    if ( defined( $v = delete $parms{'-handle_trailing_comment'} ) )
    {
        $self->{handle_trailing_comment} = $v ? 1 : 0;
    }
    if ( defined( $v = delete $parms{'-php_compat'} ) )
    {
        $self->{php_compat} = $v ? 1 : 0;
    }

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

    # make sure that comment character is always allowed
    $self->{allowed_comment_char} .= $self->{comment_char};

    $self->{_comments_at_end_of_file} = [];

    # Any other parameters are unknown
    while ( ( $k, $v ) = each %parms )
    {
        carp "Unknown named parameter $k=>$v";
        $errs++;
    }

    return undef if $errs;

    if ( $self->ReadConfig )
    {
        return $self;
    }
    else
    {
        return undef;
    }
}


sub _caseify
{
    my ( $self, @refs ) = @_;

    if ( $self->_nocase )
    {
        foreach my $ref ( grep { defined } @refs[ 0 .. 1 ] )
        {
            ${$ref} = lc( ${$ref} );
        }
    }

    if ( $self->{php_compat} )
    {
        foreach my $ref ( grep { defined } @refs[ 1 .. 1 ] )
        {
            ${$ref} =~ s{\[\]$}{};
        }
        foreach my $ref ( grep { defined } @refs[ 2 .. $#refs ] )
        {
            if ( length( ${$ref} ) >= 2 )
            {
                my $quote = substr( ${$ref}, 0, 1 );
                if ( ( $quote eq q{"} or $quote eq q{'} )
                    and substr( ${$ref}, -1, 1 ) eq $quote )
                {
                    ${$ref} = substr( ${$ref}, 1, -1 );
                    ${$ref} =~ s{$quote$quote}{}g;
                    ${$ref} =~ s{\\$quote}{$quote}g if $quote eq q{"};
                }
            }
        }
    }

    return;
}

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

    # Always return undef on bad parameters
    if ( not( defined($sect) && defined($parm) ) )
    {
        return;
    }

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

    my $val_sect =
        defined( $self->{v}{$sect}{$parm} )
        ? $sect
        : $self->{default};

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

    # If the value is undef, make it $def instead (which could just be undef)
    if ( !defined($val) )
    {
        $val = $def;
    }

    # Return the value in the desired context
    if (wantarray)
    {
        if ( ref($val) eq "ARRAY" )
        {
            return @$val;
        }
        elsif ( defined($val) )
        {
            return $val;
        }
        else
        {
            return;
        }
    }
    elsif ( ref($val) eq "ARRAY" )
    {
        return join( ( defined($/) ? $/ : "\n" ), @$val );
    }
    else
    {
        return $val;
    }
}


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

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

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


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

    return undef if not defined $sect;
    return undef if not defined $parm;

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

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

    return 1 if ( !@vals );

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

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

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

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


sub setval
{
    my $self = shift;
    my $sect = shift;
    my $parm = shift;
    my @val  = @_;

    return undef if not defined $sect;
    return undef if not defined $parm;

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

    if ( defined( $self->{v}{$sect}{$parm} ) )
    {
        $self->_touch_parameter( $sect, $parm );
        if ( @val > 1 )
        {
            $self->{v}{$sect}{$parm}   = \@val;
            $self->{EOT}{$sect}{$parm} = 'EOT';
        }
        else
        {
            $self->{v}{$sect}{$parm} = shift @val;
        }
        return 1;
    }
    else
    {
        return undef;
    }
}


sub newval
{
    my $self = shift;
    my $sect = shift;
    my $parm = shift;
    my @val  = @_;

    return undef if not defined $sect;
    return undef if not defined $parm;

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

    $self->AddSection($sect);

    if ( none { $_ eq $parm } @{ $self->{parms}{$sect} } )
    {
        CORE::push( @{ $self->{parms}{$sect} }, $parm );
    }

    $self->_touch_parameter( $sect, $parm );
    if ( @val > 1 )
    {
        $self->{v}{$sect}{$parm} = \@val;
        if ( !defined $self->{EOT}{$sect}{$parm} )
        {
            $self->{EOT}{$sect}{$parm} = 'EOT';
        }
    }
    else
    {
        $self->{v}{$sect}{$parm} = shift @val;
    }
    return 1;
}


sub delval
{
    my $self = shift;
    my $sect = shift;
    my $parm = shift;

    return undef if not defined $sect;
    return undef if not defined $parm;

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

    $self->{parms}{$sect} = [ grep { $_ ne $parm } @{ $self->{parms}{$sect} } ];
    $self->_touch_parameter( $sect, $parm );
    delete $self->{v}{$sect}{$parm};

    return 1;
}


# Auxiliary function to make deep (aliasing-free) copies of data
# structures.  Ignores blessed objects in tree (could be taught not
# to, if needed)
sub _deepcopy
{
    my $ref = shift;

    if ( !ref($ref) )
    {
        return $ref;
    }

    if ( UNIVERSAL::isa( $ref, "ARRAY" ) )
    {
        return [ map { _deepcopy($_) } @$ref ];
    }

    if ( UNIVERSAL::isa( $ref, "HASH" ) )
    {
        my $return = {};
        foreach my $k ( keys %$ref )
        {
            $return->{$k} = _deepcopy( $ref->{$k} );
        }
        return $return;
    }

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

# Internal method, gets the next line, taking proper care of line endings.
sub _nextline
{
    my ( $self, $fh ) = @_;
    my $s = '';
    if ( !exists $self->{line_ends} )
    {
        # no $self->{line_ends} is a hint set by caller that we are at
        # the first line (kludge kludge).
        {
            local $/ = \1;
            my $nextchar;
            do
            {
                $nextchar = <$fh>;
                return undef if ( !defined $nextchar );
                $s .= $nextchar;
            } until ( $s =~ m/((\015|\012|\025|\n)$)/s );
            $self->{line_ends} = $1;
            if ( $nextchar eq "\x0d" )
            {
                # peek at the next char
                $nextchar = <$fh>;
                if ( $nextchar eq "\x0a" )
                {
                    $self->{line_ends} .= "\x0a";
                }
                else
                {
                    seek $fh, -1, SEEK_CUR();
                }
            }
        }

        # If there's a UTF BOM (Byte-Order-Mark) in the first
        # character of the first line then remove it before processing
        # ( http://www.unicode.org/unicode/faq/utf_bom.html#22 )
        $s =~ s/\A//;

        return $s;
    }
    else
    {
        local $/ = $self->{line_ends};
        return scalar <$fh>;
    }
}

# Internal method, closes or resets the file handle. To be called
# whenever ReadConfig() returns.
sub _rollback
{
    my ( $self, $fh ) = @_;

    # Only close if this is a filename, if it's
    # an open handle, then just roll back to the start
    if ( !ref( $self->{cf} ) )
    {
        close($fh) or Carp::confess("close failed: $!");
    }
    else
    {
       # Attempt to rollback to beginning, no problem if this fails (e.g. STDIN)
        seek( $fh, 0, SEEK_SET() );
    }    # end if
}

sub _no_filename
{
    my $self = shift;

    my $fn = $self->{cf};

    return ( not( defined($fn) && length($fn) ) );
}

sub _read_line_num
{
    my $self = shift;

    if (@_)
    {
        $self->{_read_line_num} = shift;
    }

    return $self->{_read_line_num};
}

# Reads the next line and removes the end of line from it.
sub _read_next_line
{
    my ( $self, $fh ) = @_;

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

    if ( !defined($line) )
    {
        return undef;
    }

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

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

    return $line;
}

sub _add_error
{
    my ( $self, $msg ) = @_;

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

    return;
}

# The current section - used for parsing.
sub _curr_sect
{
    my $self = shift;

    if (@_)
    {
        $self->{_curr_sect} = shift;
    }

    return $self->{_curr_sect};
}

# The current parameter - used for parsing.
sub _curr_parm
{
    my $self = shift;

    if (@_)
    {
        $self->{_curr_parm} = shift;
    }

    return $self->{_curr_parm};
}

# Current location - section and parameter.
sub _curr_loc
{
    my $self = shift;

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

# The current value - used in parsing.
sub _curr_val
{
    my $self = shift;

    if (@_)
    {
        $self->{_curr_val} = shift;
    }

    return $self->{_curr_val};
}

sub _curr_cmts
{
    my $self = shift;

    if (@_)
    {
        $self->{_curr_cmts} = shift;
    }

    return $self->{_curr_cmts};
}

sub _curr_end_comment
{
    my $self = shift;

    if (@_)
    {
        $self->{_curr_end_comment} = shift;
    }

    return $self->{_curr_end_comment};
}

my $RET_CONTINUE = 1;
my $RET_BREAK;

sub _ReadConfig_handle_comment
{
    my ( $self, $line ) = @_;

    if ( $self->{negativedeltas}
        and my ($to_delete) =
        $line =~ m/\A$self->{comment_char} (.*) is deleted\z/ )
    {
        if ( my ($sect) = $to_delete =~ m/\A\[(.*)\]\z/ )
        {
            $self->DeleteSection($sect);
        }
        else
        {
            $self->delval( $self->_curr_sect, $to_delete );
        }
    }
    else
    {
        CORE::push( @{ $self->_curr_cmts }, $line );
    }

    return $RET_CONTINUE;
}

sub _ReadConfig_new_section
{
    my ( $self, $sect ) = @_;

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

    $self->_curr_sect($sect);
    $self->AddSection( $self->_curr_sect );
    $self->SetSectionComment( $self->_curr_sect, @{ $self->_curr_cmts } );
    $self->_curr_cmts( [] );

    return $RET_CONTINUE;
}

sub _handle_fallback_sect
{
    my ($self) = @_;

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

    return;
}

sub _ReadConfig_load_value
{
    my ( $self, $val_aref ) = @_;

    # Now load value
    if (   exists $self->{v}{ $self->_curr_sect }{ $self->_curr_parm }
        && exists $self->{myparms}{ $self->_curr_sect }
        && $self->_is_parm_in_sect( $self->_curr_loc ) )
    {
        $self->push( $self->_curr_loc, @$val_aref );
    }
    else
    {
        # Loaded parameters shadow imported ones, instead of appending
        # to them
        $self->newval( $self->_curr_loc, @$val_aref );
    }

    return;
}

sub _test_for_fallback_or_no_sect
{
    my ( $self, $fh ) = @_;

    $self->_handle_fallback_sect;

    if ( !defined $self->_curr_sect )
    {
        $self->_add_error(
            sprintf( '%d: %s',
                $self->_read_line_num(),
                qq#parameter found outside a section# )
        );
        $self->_rollback($fh);
        return $RET_BREAK;
    }

    return $RET_CONTINUE;
}

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

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

HERE_DOC_LOOP:
    while ( defined( my $line = $self->_read_next_line($fh) ) )
    {
        if ( $line eq $eotmark )
        {
            $foundeot = 1;
            last HERE_DOC_LOOP;
        }
        else
        {
            # Untaint
            my ($contents) = $line =~ /(.*)/ms;
            CORE::push( @$val_aref, $contents );
        }
    }

    if ( !$foundeot )
    {
        $self->_add_error(
            sprintf( '%d: %s',
                $startline, qq#no end marker ("$eotmark") found# )
        );
        $self->_rollback($fh);
        return $RET_BREAK;
    }

    return $RET_CONTINUE;
}

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

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

    # process continuation lines, if any
    $self->_process_continue_val($fh);

    # we should split value and comments if there is any comment
    if ( $end_commenthandle
        and my ( $value_to_assign, $end_comment_to_assign ) =
        $self->_curr_val =~ /(.*?)\s*[$allCmt]\s*(.*)$/ )
    {
        $self->_curr_val($value_to_assign);
        $self->_curr_end_comment($end_comment_to_assign);
    }
    else
    {
        $self->_curr_end_comment(q{});
    }

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

    return;
}

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

    $self->_ReadConfig_load_value($val_aref);

    $self->SetParameterComment( $self->_curr_loc, @{ $self->_curr_cmts } );
    $self->_curr_cmts( [] );
    if ( defined $eotmark )
    {
        $self->SetParameterEOT( $self->_curr_loc, $eotmark );
    }

# if handle_trailing_comment is off, this line makes no sense, since all $end_comment=""
    $self->SetParameterTrailingComment( $self->_curr_loc,
        $self->_curr_end_comment );

    return;
}

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

    $self->_caseify( undef, \$parm, \$value_to_assign );

    $self->_curr_val($value_to_assign);
    $self->_curr_end_comment( undef() );

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

        return $RET_BREAK;
    }

    $self->_curr_parm($parm);

    my @val = ();
    my $eotmark;

    if ( ($eotmark) = $self->_curr_val =~ /\A<<(.*)$/ )
    {
        if (
            !defined(
                $self->_ReadConfig_handle_here_doc_param(
                    $fh, $eotmark, \@val
                )
            )
            )
        {
            return $RET_BREAK;
        }
    }
    else
    {
        $self->_ReadConfig_handle_non_here_doc_param( $fh, \@val );
    }

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

    return $RET_CONTINUE;
}

# Return 1 to continue - undef to terminate the loop.
sub _ReadConfig_handle_line
{
    my ( $self, $fh, $line ) = @_;

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

    # ignore blank lines
    if ( $line =~ /\A\s*\z/ )
    {
        return $RET_CONTINUE;
    }

    # collect comments
    if ( $line =~ /\A\s*[$allCmt]/ )
    {
        return $self->_ReadConfig_handle_comment($line);
    }

    # New Section
    if ( my ($sect) = $line =~ /\A\s*\[\s*(\S|\S.*\S)\s*\]\s*\z/ )
    {
        return $self->_ReadConfig_new_section($sect);
    }

    # New parameter
    if ( my ( $parm, $value_to_assign ) =
        $line =~ /^\s*([^=]*?[^=\s])\s*=\s*(.*)$/ )
    {
        return $self->_ReadConfig_param_assignment( $fh, $line, $parm,
            $value_to_assign );
    }

    $self->_add_error(
        sprintf(
            "Line %d in file %s is malformed:\n\t\%s",
            $self->_read_line_num(),
            $self->GetFileName(), $line
        )
    );

    return $RET_CONTINUE;
}

sub _ReadConfig_lines_loop
{
    my ( $self, $fh ) = @_;

    $self->_curr_sect( undef() );
    $self->_curr_parm( undef() );
    $self->_curr_val( undef() );
    $self->_curr_cmts( [] );

    while ( defined( my $line = $self->_read_next_line($fh) ) )
    {
        if (
            !defined( scalar( $self->_ReadConfig_handle_line( $fh, $line ) ) ) )
        {
            return undef;
        }
    }

    return 1;
}

sub ReadConfig
{
    my $self = shift;

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

    # Initialize (and clear out) storage hashes
    $self->{sects} = [];
    $self->{parms} = {};
    $self->{group} = {};
    $self->{v}     = {};
    $self->{sCMT}  = {};
    $self->{pCMT}  = {};
    $self->{EOT}   = {};
    $self->{mysects} =
        [];    # A pair of hashes to remember which params are loaded
    $self->{myparms} = {};    # or set using the API vs. imported - useful for
    $self->{peCMT} =
        {}; # this will store trailing comments at the end of single-line params
    $self->{e}   = {};    # If a section already exists
    $self->{mye} = {};    # If a section already exists
         # import shadowing, see below, and WriteConfig($fn, -delta=>1)

    if ( defined $self->{imported} )
    {
        foreach my $field (qw(sects parms group v sCMT pCMT EOT e))
        {
            $self->{$field} = _deepcopy( $self->{imported}->{$field} );
        }
    }

    if ( $self->_no_filename )
    {
        return 1;
    }

    # If we want warnings, then send one to the STDERR log
    if ( $self->{reloadwarn} )
    {
        my ( $ss, $mm, $hh, $DD, $MM, $YY ) = ( localtime(time) )[ 0 .. 5 ];
        printf STDERR
            "PID %d reloading config file %s at %d.%02d.%02d %02d:%02d:%02d\n",
            $$, $self->{cf}, $YY + 1900, $MM + 1, $DD, $hh, $mm, $ss;
    }

    # Get a filehandle, allowing almost any type of 'file' parameter
    my $fh = $self->_make_filehandle( $self->{cf} );
    if ( !$fh )
    {
        carp "Failed to open $self->{cf}: $!";
        return undef;
    }

# Get mod time of file so we can retain it (if not from STDIN)
# also check if it's a real file (could have been a filehandle made from a scalar).
    if ( ref($fh) ne "IO::Scalar" && -e $fh )
    {
        if ( not exists $self->{file_mode} )
        {
            my @stats = stat $fh;
            $self->{file_mode} = sprintf( "%04o", $stats[2] )
                if defined $stats[2];
        }
    }

    # The first lines of the file must be blank, comments or start with [
    my $first = '';

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

    $self->_read_line_num(0);

    if ( !defined( $self->_ReadConfig_lines_loop($fh) ) )
    {
        return undef;
    }

    # Special case: return undef if file is empty. (suppress this line to
    # restore the more intuitive behaviour of accepting empty files)
    if ( !keys %{ $self->{v} } && !$self->{allowempty} )
    {
        $self->_add_error("Empty file treated as error");
        $self->_rollback($fh);
        return undef;
    }

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

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

    $self->_rollback($fh);
    return ( @Config::IniFiles::errors ? undef : 1 );
}


sub Sections
{
    my $self = shift;

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


sub SectionExists
{
    my $self = shift;
    my $sect = shift;

    return undef if not defined $sect;

    $self->_caseify( \$sect );

    return ( ( exists $self->{e}{$sect} ) ? 1 : 0 );
}


sub _AddSection_Helper
{
    my ( $self, $sect ) = @_;
    $self->{e}{$sect} = 1;
    CORE::push @{ $self->{sects} }, $sect;
    $self->_touch_section($sect);

    $self->SetGroupMember($sect);

    # Set up the parameter names and values lists
    $self->{parms}{$sect} ||= [];

    if ( !defined( $self->{v}{$sect} ) )
    {
        $self->{sCMT}{$sect}  = [];
        $self->{pCMT}{$sect}  = {};    # Comments above parameters
        $self->{parms}{$sect} = [];
        $self->{v}{$sect}     = {};
    }

    return;
}

sub AddSection
{
    my ( $self, $sect ) = @_;

    return undef if not defined $sect;

    $self->_caseify( \$sect );

    if ( $self->SectionExists($sect) )
    {
        return;
    }

    return $self->_AddSection_Helper($sect);
}

# Marks a section as modified by us (this includes deleted by us).
sub _touch_section
{
    my ( $self, $sect ) = @_;

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

    unless ( exists $self->{mye}{$sect} )
    {
        CORE::push @{ $self->{mysects} }, $sect;
        $self->{mye}{$sect} = 1;
    }

    return;
}

# Marks a parameter as modified by us (this includes deleted by us).
sub _touch_parameter
{
    my ( $self, $sect, $parm ) = @_;

    $self->_touch_section($sect);
    return if ( !exists $self->{v}{$sect} );
    $self->{myparms}{$sect} ||= [];

    if ( !$self->_is_parm_in_sect( $sect, $parm ) )
    {
        CORE::push @{ $self->{myparms}{$sect} }, $parm;
    }

    return;
}


sub DeleteSection
{
    my $self = shift;
    my $sect = shift;

    return undef if not defined $sect;

    $self->_caseify( \$sect );

    # This is done the fast way, change if data structure changes!!
    delete $self->{v}{$sect};
    delete $self->{sCMT}{$sect};
    delete $self->{pCMT}{$sect};
    delete $self->{EOT}{$sect};
    delete $self->{parms}{$sect};
    delete $self->{myparms}{$sect};
    delete $self->{e}{$sect};

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

    $self->RemoveGroupMember($sect);

    return 1;
}    # end DeleteSection


sub RenameSection
{
    my $self                 = shift;
    my $old_sect             = shift;
    my $new_sect             = shift;
    my $include_groupmembers = shift;
    return undef
        unless $self->CopySection( $old_sect, $new_sect,
        $include_groupmembers );
    return $self->DeleteSection($old_sect);

}    # end RenameSection


sub CopySection
{
    my $self                 = shift;
    my $old_sect             = shift;
    my $new_sect             = shift;
    my $include_groupmembers = shift;

    if (   not defined $old_sect
        or not defined $new_sect
        or !$self->SectionExists($old_sect)
        or $self->SectionExists($new_sect) )
    {
        return undef;
    }

    $self->_caseify( \$new_sect );
    $self->_AddSection_Helper($new_sect);

    # This is done the fast way, change if data structure changes!!
    foreach my $key (qw(v sCMT pCMT EOT parms myparms e))
    {
        next unless exists $self->{$key}{$old_sect};
        $self->{$key}{$new_sect} =
            Config::IniFiles::_deepcopy( $self->{$key}{$old_sect} );
    }

    if ($include_groupmembers)
    {
        foreach my $old_groupmember ( $self->GroupMembers($old_sect) )
        {
            my $new_groupmember = $old_groupmember;
            $new_groupmember =~ s/\A\Q$old_sect\E/$new_sect/;
            $self->CopySection( $old_groupmember, $new_groupmember );
        }
    }

    return 1;
}    # end CopySection


sub _aref_or_empty
{
    my ($aref) = @_;

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

sub Parameters
{
    my $self = shift;
    my $sect = shift;

    return undef if not defined $sect;

    $self->_caseify( \$sect );

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


sub Groups
{
    my $self = shift;

    if ( ref( $self->{group} ) eq 'HASH' )
    {
        return keys %{ $self->{group} };
    }
    else
    {
        return ();
    }
}


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

    return undef if not defined $sect;

    if ( !( my ($group) = ( $sect =~ /\A(\S+)\s+\S/ ) ) )
    {
        return 1;
    }
    else
    {
        return $self->$method( $sect, $group );
    }
}

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

    if ( not exists( $self->{group}{$group} ) )
    {
        $self->{group}{$group} = [];
    }

    if ( none { $_ eq $sect } @{ $self->{group}{$group} } )
    {
        CORE::push @{ $self->{group}{$group} }, $sect;
    }

    return;
}

sub SetGroupMember
{
    my ( $self, $sect ) = @_;

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


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

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

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

    return;
}

sub RemoveGroupMember
{
    my ( $self, $sect ) = @_;

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


sub GroupMembers
{
    my ( $self, $group ) = @_;

    return undef if not defined $group;

    $self->_caseify( \$group );

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


sub SetWriteMode
{
    my ( $self, $mode ) = @_;

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

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


sub GetWriteMode
{
    my $self = shift;

    return $self->{file_mode};
}


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

    if ( -e $filename )
    {
        if ( not( -w $filename ) )
        {
            #carp "File $filename is not writable.  Refusing to write config";
            return undef;
        }
        if ( not exists $self->{file_mode} )
        {
            my $mode = ( stat $filename )[2];
            $self->{file_mode} = sprintf "%04o", ( $mode & 0777 );
        }

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

    my ( $fh, $new_file );

    # We need to trap the exception that tempfile() may throw and instead
    # carp() and return undef() because that was the previous behaviour:
    #
    # See RT #77039 ( https://rt.cpan.org/Ticket/Display.html?id=77039 )
    eval {
        ( $fh, $new_file ) =
            tempfile( "temp.ini-XXXXXXXXXX", DIR => dirname($filename) );

        # Convert the filehandle to a "text" filehandle suitable for use
        # on Windows (and other platforms).
        #
        # This may break compatibility for ultra-old perls (ones before 5.6.0)
        # so I say - Good Riddance!
        if ( $^O =~ m/\AMSWin/ )
        {
            binmode $fh, ':crlf';
        }
    };

    if ($@)
    {
        carp("Unable to write temp config file: $!");
        return undef;
    }

    $self->OutputConfigToFileHandle( $fh, $parms{-delta} );
    close($fh) or Carp::confess("close failed: $!");
    if ( !rename( $new_file, $filename ) )
    {
        carp "Unable to rename temp config file ($new_file) to ${filename}: $!";
        return undef;
    }
    if ( exists $self->{file_mode} )
    {
        if ( not chmod( oct( $self->{file_mode} ), $filename ) )
        {
            carp "Unable to chmod $filename!";
        }
    }

    return 1;
}

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

    # Only roll back if it's not STDIN (if it is, Carp)
    if ( $fh == \*STDIN )
    {
        carp "Cannot write configuration file to STDIN.";
    }
    else
    {
        seek( $fh, 0, SEEK_SET() );

        # Make sure to keep the previous junk out.
        # See:
        # https://rt.cpan.org/Public/Bug/Display.html?id=103496
        truncate( $fh, 0 );
        $self->OutputConfigToFileHandle( $fh, $parms{-delta} );
        seek( $fh, 0, SEEK_SET() );
    }    # end if

    return 1;
}

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

    # Get a filehandle, allowing almost any type of 'file' parameter
    ## NB: If this were a filename, this would fail because _make_file
    ##     opens a read-only handle, but we have already checked that case
    ##     so re-using the logic is ok [JW/WADG]
    my $fh = $self->_make_filehandle($file);

    if ( !$fh )
    {
        carp "Could not find a filehandle for the input stream ($file): $!";
        return undef;
    }

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

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

    return undef unless defined $file;

    # If we are using a filename, then do mode checks and write to a
    # temporary file to avoid a race condition
    if ( !ref($file) )
    {
        return $self->_write_config_to_filename( $file, %parms );
    }

    # Otherwise, reset to the start of the file and write, unless we are using
    # STDIN
    else
    {
        return $self->_write_config_to_fh( $file, %parms );
    }
}


sub RewriteConfig
{
    my $self = shift;

    if ( $self->_no_filename )
    {
        return 1;
    }

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


sub GetFileName
{
    my $self = shift;

    return $self->{cf};
}


sub SetFileName
{
    my ( $self, $new_filename ) = @_;

    if ( length($new_filename) > 0 )
    {
        return ( $self->{cf} = $new_filename );
    }
    else
    {
        return undef;
    }
}


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

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

    # Make sure the $eotmark does not occur inside the string.
    my @letters    = ( 'A' .. 'Z' );
    my $joined_val = join( q{ }, @$val );
    while ( index( $joined_val, $eotmark ) >= 0 )
    {
        $eotmark .= $letters[ rand(@letters) ];
    }

    return $eotmark;
}

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

    my $line_loop = sub {
        my ($mapper) = @_;

        foreach my $line ( @{$val}[ 0 .. $#$val - 1 ] )
        {
            $output_cb->( $mapper->($line) );
        }
        $output_cb->(
            $mapper->( $val->[-1] ),
            ( $end_comment ? (" $self->{comment_char} $end_comment") : () ),
        );
        return;
    };

    if ( !@$val )
    {
        # An empty variable - see:
        # https://rt.cpan.org/Public/Bug/Display.html?id=68554
        $output_cb->("$parm=");
    }
    elsif ( ( @$val == 1 ) or $self->{nomultiline} )
    {
        $line_loop->( sub { my ($line) = @_; return "$parm=$line"; } );
    }
    else
    {
        my $eotmark = $self->_calc_eot_mark( $sect, $parm, $val );

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

    return;
}

sub OutputConfig
{
    my ( $self, $delta ) = @_;

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

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

    if ( ref($comments_aref) eq 'ARRAY' )
    {
        foreach my $comment (@$comments_aref)
        {
            $print_line->($comment);
        }
    }

    return;
}

sub _process_continue_val
{
    my ( $self, $fh ) = @_;

    if ( not $self->{allowcontinue} )
    {
        return;
    }

    my $val = $self->_curr_val;

    while ( $val =~ s/\\\z// )
    {
        $val .= $self->_read_next_line($fh);
    }

    $self->_curr_val($val);

    return;
}

sub _output_param_total
{
    my ( $self, $sect, $parm, $print_line, $split_val, $delta ) = @_;
    if ( !defined $self->{v}{$sect}{$parm} )
    {
        if ($delta)
        {
            $print_line->("$self->{comment_char} $parm is deleted");
        }
        else
        {
            warn "Weird unknown parameter $parm" if $^W;
        }
        return;
    }

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

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

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

    $self->_OutputParam( $sect, $parm, $split_val->($val),
        ( defined($end_comment) ? $end_comment : "" ), $print_line, );

    return;
}

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

    if ( !defined $self->{v}{$sect} )
    {
        if ($delta)
        {
            $print_line->("$self->{comment_char} [$sect] is deleted");
        }
        else
        {
            warn "Weird unknown section $sect" if $^W;
        }
        return;
    }
    return          if not defined $self->{v}{$sect};
    $print_line->() if ( $position > 0 );
    $self->_output_comments( $print_line, $self->{sCMT}{$sect} );

    if ( !( $self->{fallback_used} and $sect eq $self->{fallback} ) )
    {
        $print_line->("[$sect]");
    }
    return if ref( $self->{v}{$sect} ) ne 'HASH';

    foreach my $parm ( @{ $self->{ $delta ? "myparms" : "parms" }{$sect} } )
    {
        $self->_output_param_total( $sect, $parm, $print_line, $split_val,
            $delta );
    }

    return;
}

sub OutputConfigToFileHandle
{
    # We need no strict 'refs' to be able to print to $fh if it points
    # to a glob filehandle.
    no strict 'refs';
    my ( $self, $fh, $delta ) = @_;

    my $ors =
           $self->{line_ends}
        || $\
        || "\n";    # $\ is normally unset, but use input by default
    my $print_line = sub {
        print {$fh} ( @_, $ors )
            or die
"Config-IniFiles cannot print to filehandle (out-of-space?). Aborting!";
        return;
    };
    my $split_val = sub {
        my ($val) = @_;

        return (
            ( ref($val) eq 'ARRAY' )
            ? $val
            : [ split /[$ors]/, $val, -1 ]
        );
    };

    my $position = 0;

    foreach my $sect ( @{ $self->{ $delta ? "mysects" : "sects" } } )
    {
        $self->_output_section( $sect, $print_line, $split_val, $delta,
            $position++ );
    }

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

    return 1;
}


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

    if ( not( defined($sect) && @comment ) )
    {
        return undef;
    }

    $self->_caseify( \$sect );

    $self->_touch_section($sect);

    # At this point it's possible to have a comment for a section that
    # doesn't exist. This comment will not get written to the INI file.
    $self->{sCMT}{$sect} = $self->_markup_comments( \@comment );

    return scalar @comment;
}

# this helper makes sure that each line is preceded with the correct comment
# character
sub _markup_comments
{
    my ( $self, $comment_aref ) = @_;

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

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

    # TODO : Maybe create a qr// out of it.
    return [ map { ( $_ =~ $is_comment ) ? $_ : "$cmtChr $_" } @$comment_aref ];
}


sub _return_comment
{
    my ( $self, $comment_aref ) = @_;

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

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

sub GetSectionComment
{
    my ( $self, $sect ) = @_;

    return undef if not defined $sect;

    $self->_caseify( \$sect );

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

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


sub DeleteSectionComment
{
    my $self = shift;
    my $sect = shift;

    return undef if not defined $sect;

    $self->_caseify( \$sect );
    $self->_touch_section($sect);

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

    return;
}


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

    if ( not( defined($sect) && defined($parm) && @comment ) )
    {
        return undef;
    }

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

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

    # Note that at this point, it's possible to have a comment for a parameter,
    # without that parameter actually existing in the INI file.
    $self->{pCMT}{$sect}{$parm} = $self->_markup_comments( \@comment );

    return scalar @comment;
}

sub _SetEndComments
{
    my $self     = shift;
    my @comments = @_;

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

    return 1;
}

sub _GetEndComments
{
    my $self = shift;

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


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

    if ( not( defined($sect) && defined($parm) ) )
    {
        return undef;
    }

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

    if (
        not(   exists( $self->{pCMT}{$sect} )
            && exists( $self->{pCMT}{$sect}{$parm} ) )
        )
    {
        return undef;
    }

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


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

    if ( not( defined($sect) && defined($parm) ) )
    {
        return undef;
    }

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

    # If the parameter doesn't exist, our goal has already been achieved
    if (   exists( $self->{pCMT}{$sect} )
        && exists( $self->{pCMT}{$sect}{$parm} ) )
    {
        $self->_touch_parameter( $sect, $parm );
        delete $self->{pCMT}{$sect}{$parm};
    }

    return 1;
}


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

    if ( not( defined($sect) && defined($parm) ) )
    {
        return undef;
    }

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

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


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

    if ( not( defined($sect) && defined($parm) && defined($EOT) ) )
    {
        return undef;
    }

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

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

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

    return;
}


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

    if ( not( defined($sect) && defined($parm) ) )
    {
        return undef;
    }

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

    $self->_touch_parameter( $sect, $parm );
    delete $self->{EOT}{$sect}{$parm};

    return;
}


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

    if ( not( defined($sect) && defined($parm) && defined($cmt) ) )
    {
        return undef;
    }

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

    # confirm the parameter exist
    return undef if not exists $self->{v}{$sect}{$parm};

    $self->_touch_parameter( $sect, $parm );
    $self->{peCMT}{$sect}{$parm} = $cmt;

    return 1;
}


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

    if ( not( defined($sect) && defined($parm) ) )
    {
        return undef;
    }

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

    # confirm the parameter exist
    return undef if not exists $self->{v}{$sect}{$parm};
    return $self->{peCMT}{$sect}{$parm};
}


sub Delete
{
    my $self = shift;

    foreach my $section ( $self->Sections() )
    {
        $self->DeleteSection($section);
    }

    return 1;
}    # end Delete


############################################################
#
# TIEHASH Methods
#
# Description:
# These methods allow you to tie a hash to the
# Config::IniFiles object. Note that, when tied, the
# user wants to look at thinks like $ini{sec}{parm}, but the
# TIEHASH only provides one level of hash interface, so the
# root object gets asked for a $ini{sec}, which this
# implements. To further tie the {parm} hash, the internal
# class Config::IniFiles::_section, is provided, below.
#
############################################################
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000May09 Created method                                JW
# ----------------------------------------------------------
sub TIEHASH
{
    my $class = shift;
    my %parms = @_;

    # Get a new object
    my $self = $class->new(%parms);

    return $self;
}    # end TIEHASH

# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000May09 Created method                                JW
# ----------------------------------------------------------
sub FETCH
{
    my $self = shift;
    my ($key) = @_;

    $self->{_section_cache} ||= {};

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

    return $self->{_section_cache}->{$key}
        if exists $self->{_section_cache}->{$key};

    my %retval;
    tie %retval, 'Config::IniFiles::_section', $self, $key;
    return $self->{_section_cache}->{$key} = \%retval;

}    # end FETCH

# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000Jun14 Fixed bug where wrong ref was saved           JW
# 2000Oct09 Fixed possible but in %parms with defaults    JW
# 2001Apr04 Fixed -nocase problem in storing              JW
# ----------------------------------------------------------
sub STORE
{
    my $self = shift;
    my ( $key, $ref ) = @_;

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

    $self->_caseify( \$key );

    $self->AddSection($key);
    $self->{v}{$key}       = {%$ref};
    $self->{parms}{$key}   = [ keys %$ref ];
    $self->{myparms}{$key} = [ keys %$ref ];

    return 1;
}    # end STORE

# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000May09 Created method                                JW
# 2000Dec17 Now removes comments, groups and EOTs too     JW
# 2001Arp04 Fixed -nocase problem                         JW
# ----------------------------------------------------------
sub DELETE
{
    my $self = shift;
    my ($key) = @_;

    my $retval = $self->FETCH($key);
    $self->DeleteSection($key);
    return $retval;
}    # end DELETE

# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000May09 Created method                                JW
# ----------------------------------------------------------
sub CLEAR
{
    my $self = shift;

    return $self->Delete();
}    # end CLEAR

# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000May09 Created method                                JW
# ----------------------------------------------------------
sub FIRSTKEY
{
    my $self = shift;

    $self->{tied_enumerator} = 0;
    return $self->NEXTKEY();
}    # end FIRSTKEY

# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000May09 Created method                                JW
# ----------------------------------------------------------
sub NEXTKEY
{
    my $self = shift;
    my ($last) = @_;

    my $i   = $self->{tied_enumerator}++;
    my $key = $self->{sects}[$i];
    return if ( !defined $key );
    return wantarray ? ( $key, $self->FETCH($key) ) : $key;
}    # end NEXTKEY

# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000May09 Created method                                JW
# 2001Apr04 Fixed -nocase bug and false true bug          JW
# ----------------------------------------------------------
sub EXISTS
{
    my $self = shift;
    my ($key) = @_;
    return $self->SectionExists($key);
}    # end EXISTS

# ----------------------------------------------------------
# DESTROY is used by TIEHASH and the Perl garbage collector,
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000May09 Created method                                JW
# ----------------------------------------------------------
sub DESTROY
{
    # my $self = shift;
}    # end if

# ----------------------------------------------------------
# Sub: _make_filehandle
#
# Args: $thing
#   $thing  An input source
#
# Description: Takes an input source - a filehandle,
# filehandle glob, reference to a filehandle glob, IO::File
# object or scalar filename - and returns a file handle to
# read from it with.
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 06Dec2001 Added to support input from any source        JW
# ----------------------------------------------------------
sub _make_filehandle
{
    my $self = shift;

    #
    # This code is 'borrowed' from Lincoln D. Stein's GD.pm module
    # with modification for this module. Thanks Lincoln!
    #

    no strict 'refs';
    my $thing = shift;

    if ( ref($thing) eq "SCALAR" )
    {
        if ( eval { require IO::Scalar; $IO::Scalar::VERSION >= 2.109; } )
        {
            return IO::Scalar->new($thing);
        }
        else
        {
            warn "SCALAR reference as file descriptor requires IO::stringy "
                . "v2.109 or later"
                if ($^W);
            return;
        }
    }

    return $thing if defined( fileno $thing );

    # otherwise try qualifying it into caller's package
    my $fh = qualify_to_ref( $thing, caller(1) );
    return $fh if defined( fileno $fh );

    # otherwise treat it as a file to open
    $fh = gensym;
    open( $fh, $thing ) || return;

    return $fh;
}    # end _make_filehandle

############################################################
#
# INTERNAL PACKAGE: Config::IniFiles::_section
#
# Description:
# This package is used to provide a single-level TIEHASH
# interface to the sections in the IniFile. When tied, the
# user wants to look at thinks like $ini{sec}{parm}, but the
# TIEHASH only provides one level of hash interface, so the
# root object gets asked for a $ini{sec} and must return a
# has reference that accurately covers the '{parm}' part.
#
# This package is only used when tied and is inter-woven
# between the sections and their parameters when the TIEHASH
# method is called by Perl. It's a very simple implementation
# of a tied hash object that simply maps onto the object API.
#
############################################################
# Date        Modification                            Author
# ----------------------------------------------------------
# 2000.May.09 Created to excapsulate TIEHASH interface    JW
############################################################
package Config::IniFiles::_section;

use strict;
use warnings;
use Carp;
use vars qw( $VERSION );

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

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::TIEHASH
#
# Args: $class, $config, $section
#   $class    The class that this is being tied to.
#   $config   The parent Config::IniFiles object
#   $section  The section this tied object refers to
#
# Description: Builds the object that implements accesses to
# the tied hash.
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# ----------------------------------------------------------
sub TIEHASH
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my ( $config, $section ) = @_;

    # Make a new object
    return bless { config => $config, section => $section }, $class;
}    # end TIEHASH

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::FETCH
#
# Args: $key
#   $key    The name of the key whose value to get
#
# Description: Returns the value associated with $key. If
# the value is a list, returns a list reference.
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2000Jun15 Fixed bugs in -default handler                JW
# 2000Dec07 Fixed another bug in -deault handler          JW
# 2002Jul04 Returning scalar values (Bug:447532)          AS
# ----------------------------------------------------------
sub FETCH
{
    my ( $self, $key ) = @_;
    my @retval = $self->{config}->val( $self->{section}, $key );
    return ( @retval <= 1 ) ? $retval[0] : \@retval;
}    # end FETCH

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::STORE
#
# Args: $key, @val
#   $key    The key under which to store the value
#   @val    The value to store, either an array or a scalar
#
# Description: Sets the value for the specified $key
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2001Apr04 Fixed -nocase bug                             JW
# ----------------------------------------------------------
sub STORE
{
    my ( $self, $key, @val ) = @_;
    return $self->{config}->newval( $self->{section}, $key, @val );
}    # end STORE

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::DELETE
#
# Args: $key
#   $key    The key to remove from the hash
#
# Description: Removes the specified key from the hash and
# returns its former value.
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2001Apr04 Fixed -nocase bug                              JW
# ----------------------------------------------------------
sub DELETE
{
    my ( $self, $key ) = @_;
    my $retval = $self->{config}->val( $self->{section}, $key );
    $self->{config}->delval( $self->{section}, $key );
    return $retval;
}    # end DELETE

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::CLEAR
#
# Args: (None)
#
# Description: Empties the entire hash
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# ----------------------------------------------------------
sub CLEAR
{
    my ($self) = @_;
    return $self->{config}->DeleteSection( $self->{section} );
}    # end CLEAR

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::EXISTS
#
# Args: $key
#   $key    The key to look for
#
# Description: Returns whether the key exists
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# 2001Apr04 Fixed -nocase bug                             JW
# ----------------------------------------------------------
sub EXISTS
{
    my ( $self, $key ) = @_;
    return $self->{config}->exists( $self->{section}, $key );
}    # end EXISTS

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::FIRSTKEY
#
# Args: (None)
#
# Description: Returns the first key in the hash
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# ----------------------------------------------------------
sub FIRSTKEY
{
    my $self = shift;

    $self->{tied_enumerator} = 0;
    return $self->NEXTKEY();
}    # end FIRSTKEY

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::NEXTKEY
#
# Args: $last
#   $last   The last key accessed by the iterator
#
# Description: Returns the next key in line
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# ----------------------------------------------------------
sub NEXTKEY
{
    my $self = shift;
    my ($last) = @_;

    my $i    = $self->{tied_enumerator}++;
    my @keys = $self->{config}->Parameters( $self->{section} );
    my $key  = $keys[$i];
    return if ( !defined $key );
    return wantarray ? ( $key, $self->FETCH($key) ) : $key;
}    # end NEXTKEY

# ----------------------------------------------------------
# Sub: Config::IniFiles::_section::DESTROY
#
# Args: (None)
#
# Description: Called on cleanup
# ----------------------------------------------------------
# Date      Modification                              Author
# ----------------------------------------------------------
# ----------------------------------------------------------
sub DESTROY
{
    # my $self = shift
}    # end DESTROY

1;



1;

# Please keep the following within the last four lines of the file
#[JW for editor]:mode=perl:tabSize=8:indentSize=2:noTabs=true:indentOnEnter=true:

__END__