view release on metacpan or  search on metacpan

lib/Config/Model.pm  view on Meta::CPAN

    $self->show_legacy_issue("$config_class_name->$elt_name: parameter cargo_type is deprecated.");
    my %cargo;

    if ( defined $info->{cargo_args} ) {
        %cargo = %{ delete $info->{cargo_args} };
        $self->show_legacy_issue(
            "$config_class_name->$elt_name: parameter cargo_args is deprecated.");
    }

    $cargo{type} = $c_type;

    if ( defined $info->{config_class_name} ) {
        $cargo{config_class_name} = delete $info->{config_class_name};
        $self->show_legacy_issue([
            "$config_class_name->$elt_name: parameter config_class_name is ",
            "deprecated. This one must be specified within cargo. ",
            "Ie. cargo=>{config_class_name => 'FooBar'}"
        ]);
    }

    $info->{cargo} = \%cargo;
    $legacy_logger->debug( 
        Data::Dumper->Dump( [$info], [ 'translated_' . $elt_name ] ) 
    ) if $legacy_logger->is_debug;
    return;
}

sub translate_allow_compute_override {
    my $self              = shift;
    my $config_class_name = shift;
    my $elt_name          = shift;
    my $info              = shift;

    if ( defined $info->{allow_compute_override} ) {
        $self->show_legacy_issue(
            "$config_class_name->$elt_name: parameter allow_compute_override is deprecated in favor of compute -> allow_override"
        );
        $info->{compute}{allow_override} = delete $info->{allow_compute_override};
    }
    return;
}

sub translate_compute_info {
    my $self              = shift;
    my $config_class_name = shift;
    my $elt_name          = shift;
    my $info              = shift;
    my $old_name          = shift;
    my $new_name          = shift || $old_name;

    if ( ref( $info->{$old_name} ) eq 'ARRAY' ) {
        my $compute_info = delete $info->{$old_name};
        $legacy_logger->debug(
            "translate_compute_info $elt_name input:\n",
            Data::Dumper->Dump( [$compute_info], [qw/compute_info/] )
        ) if $legacy_logger->is_debug;

        $self->show_legacy_issue([ "$config_class_name->$elt_name: specifying compute info with ",
            "an array ref is deprecated" ]);

        my ( $user_formula, %var ) = @$compute_info;
        my $replace_h;
        foreach ( keys %var ) { $replace_h = delete $var{$_} if ref( $var{$_} ) };

        # cleanup user formula
        $user_formula =~ s/\$(\w+)\{/\$replace{/g;

        # cleanup variable
        foreach ( values %var ) { s/\$(\w+)\{/\$replace{/g };

        # change the hash *in* the info structure
        $info->{$new_name} = {
            formula   => $user_formula,
            variables => \%var,
        };
        $info->{$new_name}{replace} = $replace_h if defined $replace_h;

        $legacy_logger->debug(
            "translate_warp_info $elt_name output:\n",
            Data::Dumper->Dump( [ $info->{$new_name} ], [ 'new_' . $new_name ] )
        ) if $legacy_logger->is_debug;
    }
    return;
}

sub translate_id_class {
    my $self              = shift;
    my $config_class_name = shift || die;
    my $elt_name          = shift;
    my $info              = shift;


    $legacy_logger->debug(
        "translate_id_class $elt_name input:\n",
        Data::Dumper->Dump( [$info], [qw/info/] )
    ) if $legacy_logger->is_debug;

    my $class_overide_param = $info->{type}.'_class';
    my $class_overide = $info->{$class_overide_param};
    if ($class_overide) {
        $info->{class} = $class_overide;
        $self->show_legacy_issue([
            "$config_class_name->$elt_name: '$class_overide_param' is deprecated, ",
            "Use 'class' instead."
        ]);
    }

    $legacy_logger->debug(
        "translate_id_class $elt_name output:",
        Data::Dumper->Dump( [$info], [qw/new_info/])
    ) if $legacy_logger->is_debug;
    return;
}

# internal: translate default information for id element
sub translate_id_default_info {
    my $self              = shift;
    my $config_class_name = shift || die;
    my $elt_name          = shift;
    my $info              = shift;

    $legacy_logger->debug(
        "translate_id_default_info $elt_name input:\n",
        Data::Dumper->Dump( [$info], [qw/info/] )
    ) if $legacy_logger->is_debug;

    my $warn = "$config_class_name->$elt_name: 'default' parameter for list or "
        . "hash element is deprecated. ";

    my $def_info = delete $info->{default};
    if ( ref($def_info) eq 'HASH' ) {
        $info->{default_with_init} = $def_info;
        $self->show_legacy_issue([ $warn, "Use default_with_init" ]);

lib/Config/Model.pm  view on Meta::CPAN

            my $elt_info = $c_model->{element}{$elt_name};
            my $summary = $elt_info->{summary} || '';
            $summary &&= " - $summary";
            push @elt, "=head2 $elt_name$summary", '';
            push @elt, $self->get_element_description($elt_info), '';

            foreach ( $elt_info, $elt_info->{cargo} ) {
                if ( my $ccn = $_->{config_class_name} ) {
                    push @classes, $ccn;
                    $see_also{$ccn} = 1;
                }
                if ( my $migr = $_->{migrate_from} ) {
                    push @elt, $self->get_migrate_doc( $elt_name, 'is migrated with', $migr );
                }
                if ( my $migr = $_->{migrate_values_from} ) {
                    push @elt, "Note: $elt_name values are migrated from '$migr'", '';
                }
                if ( my $comp = $_->{compute} ) {
                    push @elt, $self->get_migrate_doc( $elt_name, 'is computed with', $comp );
                }
            }
        }

        foreach my $what (qw/author copyright license/) {
            my $item = $c_model->{$what};
            push @{ $legalese{$what} }, $item if $item;
        }

        my @end;
        foreach my $what (qw/author copyright license/) {
            next unless @{ $legalese{$what} || [] };
            push @end, "=head1 " . uc($what), '', '=over', '',
                ( map { ( "=item $_", '' ); } map { ref $_ ? @$_ : $_ } @{ $legalese{$what} } ),
                '', '=back', '';
        }

        my @see_also = (
            "=head1 SEE ALSO",
            '',
            "=over",
            '',
            "=item *",
            '',
            "L<cme>",
            '',
            ( map { ( "=item *", '', "L<Config::Model::models::$_>", '' ); } sort keys %see_also ),
            "=back",
            ''
        );

        $result{$full_name} = join( "\n", @pod, @elt, @see_also, @end, '=cut', '' ) . "\n";
        $done->{$class_name} = 1;
    }
    return \%result;
}

sub get_migrate_doc {
    my ( $self, $elt_name, $desc, $migr ) = @_;

    my $mv    = $migr->{variables};
    my $mform = $migr->{formula};

    if ( $mform =~ /\n/) { $mform =~ s/^/ /mg; $mform = "\n\n$mform\n\n"; }
    else                 { $mform = "'C<$mform>' " }

    my $mdoc = "Note: $elt_name $desc ${mform}and with: \n\n=over\n\n=item *\n\n"
        . join( "\n\n=item *\n\n", map { qq!C<\$$_> => C<$mv->{$_}>! } sort keys %$mv );
    if ( my $rep = $migr->{replace} ) {
        $mdoc .= "\n\n=item *\n\n"
            . join( "\n\n=item *\n\n", map { qq!C<\$replace{$_}> => C<$rep->{$_}>! } sort keys %$rep );
    }
    $mdoc .= "\n\n=back\n\n";

    return ( $mdoc, '' );
}

sub get_element_description {
    my ( $self, $elt_info ) = @_;

    my $type  = $elt_info->{type};
    my $cargo = $elt_info->{cargo};
    my $vt    = $elt_info->{value_type};

    my $of         = '';
    my $cargo_type = $cargo->{type};
    my $cargo_vt   = $cargo->{value_type};
    $of = " of " . ( $cargo_vt or $cargo_type ) if defined $cargo_type;

    my $ccn = $elt_info->{config_class_name} || $cargo->{config_class_name};
    $of .= " of class L<$ccn|Config::Model::models::$ccn> " if $ccn;

    my $desc = $elt_info->{description} || '';
    if ($desc) {
        $desc .= '.' if $desc =~ /\w$/;
        $desc .= ' ' unless $desc =~ /\s$/;
    }

    if ( my $status = $elt_info->{status} ) {
        $desc .= 'B<' . ucfirst($status) . '> ';
    }

    my $info = $elt_info->{mandatory} ? 'Mandatory. ' : 'Optional. ';

    $info .= "Type " . ( $vt || $type ) . $of . '. ';

    foreach my $name (qw/choice/) {
        my $item = $elt_info->{$name};
        next unless defined $item;
        $info .= "$name: '" . join( "', '", @$item ) . "'. ";
    }

    my @default_info = ();
    # assemble in over item for string value_type
    foreach my $name (qw/default upstream_default/) {
        my $item = $elt_info->{$name};
        next unless defined $item;
        push @default_info, [$name, $item] ;
    }

    my $elt_help = $self->get_element_value_help($elt_info);