configure.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

            return
        )
    }       
    return unless $self->can_save($file);

    ### find only accesors that are not private
    my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors;

    ### for dumping the values
    use Data::Dumper;
    
    my @lines;
    for my $acc ( @acc ) {
        
        push @lines, "### $acc section", $/;
        
        for my $key ( $self->conf->$acc->ls_accessors ) {
            my $val = Dumper( $self->conf->$acc->$key );
        
            $val =~ s/\$VAR1\s+=\s+//;
            $val =~ s/;\n//;
        
            push @lines, '$'. "conf->set_${acc}( $key => $val );", $/;
        }
        push @lines, $/,$/;

    }

    my $str = join '', map { "    $_" } @lines;

    ### use a variable to make sure the pod parser doesn't snag it
    my $is      = '=';
    my $time    = gmtime;
   
    
    my $msg     = <<_END_OF_CONFIG_;
###############################################
###                                         
###  Configuration structure for $pm        
###                                         
###############################################

#last changed: $time GMT

### minimal pod, so you can find it with perldoc -l, etc
${is}pod

${is}head1 NAME

$pm

${is}head1 DESCRIPTION

This is a CPANPLUS configuration file. Editing this
config changes the way CPANPLUS will behave

${is}cut

package $pm;

use strict;

sub setup {
    my \$conf = shift;
    
$str

    return 1;    
} 

1;

_END_OF_CONFIG_

    $self->_move( file => $file, to => "$file~" ) if -f $file;

    my $fh = new FileHandle;
    $fh->open(">$file")
        or (error(loc("Could not open '%1' for writing: %2", $file, $!)),
            return );

    $fh->print($msg);
    $fh->close;

    return $file;
}

=pod

=head2 options( type => TYPE )

Returns a list of all valid config options given a specific type
(like for example C<conf> of C<program>) or false if the type does
not exist

=cut

sub options {
    my $self = shift;
    my $conf = $self->conf;
    my %hash = @_;

    my $type;
    my $tmpl = {
        type    => { required       => 1, default   => '',
                     strict_type    => 1, store     => \$type },
    };

    check($tmpl, \%hash) or return;

    my %seen;
    return sort grep { !$seen{$_}++ }
                map { $_->$type->ls_accessors if $_->can($type)  } 
                $self->conf;
    return;
}

=pod

=head1 ACCESSORS

Accessors that start with a C<_> are marked private -- regular users
should never need to use these.

See the C<CPANPLUS::Config> documentation for what items can be
set and retrieved.

=head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );

The C<get_*> style accessors merely retrieves one or more desired
config options.

=head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );

The C<set_*> style accessors set the current value for one
or more config options and will return true upon success, false on
failure.

=head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );

The C<add_*> style accessor adds a new key to a config key.

Currently, the following accessors exist:

=over 4

=item set|get_conf

Simple configuration directives like verbosity and favourite shell.

=item set|get_program

Location of helper programs.

=item _set|_get_build

Locations of where to put what files for CPANPLUS.

=item _set|_get_source

Locations and names of source files locally.

=item _set|_get_mirror

Locations and names of source files remotely.

=item _set|_get_fetch

Special settings pertaining to the fetching of files.

=back

=cut

sub AUTOLOAD {
    my $self    = shift;
    my $conf    = $self->conf;

    my $name    = $AUTOLOAD;
    $name       =~ s/.+:://;

    my ($private, $action, $field) =
                $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;

    my $type = '';
    $type .= '_'    if $private;
    $type .= $field if $field;

    unless ( $conf->can($type) ) {
        error( loc("Invalid method type: '%1'", $name) );
        return;
    }

    unless( scalar @_ ) {
        error( loc("No arguments provided!") );
        return;
    }

    ### retrieve a current value for an existing key ###
    if( $action eq 'get' ) {
        for my $key (@_) {
            my @list = ();

            ### get it from the user config first
            if( $conf->can($type) and $conf->$type->can($key) ) {
                push @list, $conf->$type->$key;

            ### XXX EU::AI compatibility hack to provide lookups like in
            ### cpanplus 0.04x; we renamed ->_get_build('base') to
            ### ->get_conf('base')
            } elsif ( $type eq '_build' and $key eq 'base' ) {
                return $self->get_conf($key);  
                
            } else {     
                error( loc(q[No such key '%1' in field '%2'], $key, $type) );
                return;
            }

            return wantarray ? @list : $list[0];
        }

    ### set an existing key to a new value ###
    } elsif ( $action eq 'set' ) {
        my %args = @_;

        while( my($key,$val) = each %args ) {

            if( $conf->can($type) and $conf->$type->can($key) ) {
                $conf->$type->$key( $val );
                
            } else {
                error( loc(q[No such key '%1' in field '%2'], $key, $type) );
                return;
            }
        }

        return 1;

    ### add a new key to the config ###
    } elsif ( $action eq 'add' ) {
        my %args = @_;

        while( my($key,$val) = each %args ) {

            if( $conf->$type->can($key) ) {
                error( loc( q[Key '%1' already exists for field '%2'],
                            $key, $type));
                return;
            } else {
                $conf->$type->mk_accessors( $key );
                $conf->$type->$key( $val );
            }
        }
        return 1;

    } else {

        error( loc(q[Unknown action '%1'], $action) );
        return;
    }
}

sub DESTROY { 1 };

1;

=pod

=head1 BUG REPORTS

Please report bugs or other issues to E<lt>[e-mail]<gt>.

=head1 AUTHOR

This module by Jos Boumans E<lt>[e-mail]<gt>.

=head1 COPYRIGHT

The CPAN++ interface (of which this module is a part of) is copyright (c) 
2001 - 2007, Jos Boumans E<lt>[e-mail]<gt>. All rights reserved.

This library is free software; you may redistribute and/or modify it 
under the same terms as Perl itself.

=head1 SEE ALSO

L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config>

=cut

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4: