view release on metacpan or  search on metacpan

contrib/parse-man.pl  view on Meta::CPAN

        my @choices;

        # handle "Takes the same settings as ..." (seen only for enum)
        if ($desc =~ /takes the same values as the (?:setting )?C<(\w+)>/i) {
            my $other = $1;
            my $other_obj = $obj->grab("- element:$other");
            @choices = $other_obj->fetch_element('choice')->fetch;
            say "Copy enum choices from $other to ", $obj->location;
        }
        elsif ($extra_info =~ /\w\|\w/) {
            @choices = split /\|/, $extra_info ;
        }
        elsif ($desc =~ /Takes a boolean (argument,? )?or /) {
            my ($choices) = ($desc =~ /Takes a boolean (?:argument,? )?or (?:the )?(?:special values|architecture identifiers\s*)?([^.]+?)\./);
            @choices = ('no','yes');
            push @choices, extract_choices($choices);
            push @load, qw/replace:false=no replace:true=yes replace:0=no replace:1=yes/;
        }

        if ($desc =~ /Takes one of/) {
            my ($choices) = ($desc =~ /Takes one of ([^.]+?)(?:\.|to test)/);
            @choices = extract_choices($choices);
        }

        die "Error in $config_class: cannot find the values of $element enum type from «$desc»\n"
            unless @choices;
        push @log, "enum choices are '".join("', '", sort @choices)."'";
        push @load_extra, 'choice='.join(',',sort @choices);
    }


    push @load_extra, "min=$min" if defined $min;
    push @load_extra, "max=$max" if defined $max;

    if ($value_type eq 'integer' and $desc =~ /defaults? (?:value )?(?:to|is) (\d+)/i) {
        push @load_extra, "upstream_default=$1" ;
    }

    if ($value_type eq 'enum' and $desc =~ /Defaults? (?:value )?(?:to|is) (\w+)\./) {
        my $v = ($1 =~ s/true|on/yes/r);
        $v =~ s/false|off/no/;
        push @load_extra, "upstream_default=$v" ;
    }

    if ($value_type eq 'boolean' and $desc =~ /Defaults? (?:value )?(?:to|is) (C<)?(true|on|yes)>?\./) {
        push @load_extra, "upstream_default=yes" ;
    }
    if ($value_type eq 'boolean' and $desc =~ /Defaults? (?:value )?(?:to|is) (C<)?(false|off|no)>?\./) {
        push @load_extra, "upstream_default=no" ;
    }

    if ($supersedes) {
        push @load_extra, "status=deprecated";

        push @log, "deprecated in favor of $supersedes";
        # put migration in place for the other element
        my $new = $meta_root->grab(
            step => "class:$config_class element:$supersedes",
            autoadd => 1
        );
        $new->load(steps => qq!migrate_from variables:old="- $element" formula="\$old"!);
    }
    $obj->load(step => [@load, @load_extra]);

    say "class $config_class element $element:\n\t".join("\n\t", @log) if @log;
    return $obj;
}

sub extract_choices($choices) {
    my @choices = ($choices =~ m!C<([/\w\-+]+)>!g );
    if ($choices =~ m{possibly prefixed with (?:a )?C<([!\w]+)>} ) {
        push @choices, map { "$1$_"} @choices;
    }
    return @choices;
}

sub move_deprecated_element ($meta_root, $from, $to) {
    say "Handling move of service/$from to unit/$to...";
    # create deprecated moved element in Service for backward compat
    my $warn = $from eq $to ? "$from is now part of Unit."
        : "service/$from is now Unit/$to.";
    $meta_root->load( steps => [
        'class:Systemd::Section::Service',
        qq!element:$from type=leaf value_type=uniline status=deprecated!,
        qq!warn="$warn"!
    ]);

    # Due to the fact that Unit are used in Service, Timer, Socket but
    # only Service needs backward compat, a special Unit class is created
    # for each Service.

    # Saving $to definition stored from data extracted from Systemd
    # doc
    my $from_element_dump = $meta_root->grab(
        "class:Systemd::Section::Unit element:$to"
    )->dump_tree;

    # remove $from element from common Unit class
    $meta_root->load("class:Systemd::Section::Unit element:.rm($to)");

    foreach my $service (@service_list) {
        my $unit_class = "Systemd::Section::". ucfirst($service).'Unit';

        # inject $from element in Special Unit class
        $meta_root
            ->grab("class:$unit_class element:$to")
            ->load($from_element_dump);

        # make sure that special Unit class provide all elements from
        # common Unit class
        $meta_root->load(steps => [
            "class:$unit_class include=Systemd::Section::Unit",
            'accept:".*" type=leaf value_type=uniline warn="$unknown_param_msg"'
        ]);
    }

    # inject the migration instruction that retrieve $from element setting
    # from Service class (where it's deprecated) and copy them to the new
    # $from element in Unit class in a service file (hence this migration
    # instruction is done only in ServiceUnit class)
    $meta_root->load( steps => [
        qq!class:Systemd::Section::ServiceUnit element:$to!,
        qq!migrate_from variables:service="- - Service $from" formula="\$service"!
    ]);
}

my $data = parse_xml([@list, @service_list], \%map) ;

# Itself constructor returns an object to read or write the data
# structure containing the model to be edited
my $rw_obj = Config::Model::Itself -> new () ;

# now load the existing model to be edited
$rw_obj -> read_all() ;
my $meta_root = $rw_obj->meta_root;

# remove old generated classes
foreach my $config_class ($meta_root->fetch_element('class')->fetch_all_indexes) {
    my $gen = $meta_root->grab_value(
        step => qq!class:$config_class generated_by!,
        mode => 'loose',
    );
    next unless $gen and $gen =~ /parse-man/;
    $meta_root->load(qq!class:-$config_class!);
}


say "Creating systemd model...";

foreach my $config_class (keys $data->{class}->%*) {
    say "Creating model class $config_class";
    my $desc_ref = $data->{class}{$config_class};

    # cleanup leading white space and add formatting
    my $desc_text = join("\n\n", map { s/\n[\t ]+/\n/gr =~ s/C<([A-Z]\w+)=>/C<$1>/gr;} $desc_ref->@*);

    $desc_text.="\nThis configuration class was generated from systemd documentation.\n"
        ."by L<parse-man.pl|https://github.com/dod38fr/config-model-systemd/contrib/parse-man.pl>\n";

    # detect verbatim parts setup with programlisting tag
    $desc_text =~ s/^\+-\+/    /gm;

    my $steps = "class:$config_class class_description";
    $meta_root->grab(step => $steps, autoadd => 1)->store($desc_text);

    $meta_root->load( steps => [
        qq!class:$config_class generated_by="parse-man.pl from systemd $systemd_version doc"!,
        qq!copyright:0="2010-2016 Lennart Poettering and others"!,
        qq!copyright:1="2016 Dominique Dumont"!,
        qq!license="LGPLv2.1+"!,
        qq!accept:".*" type=leaf value_type=uniline warn="$unknown_param_msg"!,
    ]);
}

foreach my $cdata ($data->{element}->@*) {
    my ($config_class, $element, $desc, $extra_info, $supersedes) = $cdata->@*;

    my $obj = setup_element ($meta_root, $config_class, $element, $desc, $extra_info, $supersedes);

    $desc =~ s/ +$//gm;
    $obj->fetch_element("description")->store(wrap('','',$desc));
}

contrib/parse-man.pl  view on Meta::CPAN

    $meta_root->load(
        qq!
        class:Systemd::StandAlone::$name
          element:$name
            type=node
            config_class_name=$sub_class -
          element:Unit
            type=node
            config_class_name=Systemd::Section::$unit_class -
          element:Install
            type=node
            config_class_name=Systemd::Section::Install -
          rw_config
            backend=Systemd::Unit
            auto_delete=1
            auto_create=1 !
    );

    # Link the class above to base Systemd class
    $meta_root->load(
        qq!
        class:Systemd
          generated_by="parse-man.pl from systemd doc"
          element:$service
            type=hash
            index_type=string
            cargo
              type=node
              config_class_name=Systemd::$name - -
          rw_config
            backend=Systemd
            auto_create=1
            auto_delete=1 -
          !
    );
}

my @moved = qw/FailureAction SuccessAction StartLimitBurst StartLimitInterval RebootArgument/;
my %move_target = qw/StartLimitInterval StartLimitIntervalSec/;

# check also src/core/load-fragment-gperf.gperf.m4 is systemd source
# for "compatibility" elements
foreach my $from (@moved) {
    my $to = $move_target{$from} || $from;
    move_deprecated_element($meta_root, $from, $to);
}

# StartLimitInterval is also deprecated in Unit
say "Handling move of StartLimitInterval to StartLimitIntervalSec in unit";
$meta_root->load( steps => [
    'class:Systemd::Section::Unit',
    qq!element:StartLimitInterval type=leaf value_type=uniline status=deprecated!,
    qq!warn="StartLimitInterval is now StartLimitIntervalSec."!
]);

# handle migration from both service and unit
$meta_root->load( steps => [
    qq!class:Systemd::Section::ServiceUnit element:StartLimitIntervalSec!,
    qq!migrate_from variables:unit="- StartLimitInterval"!,
    # $service variable is defined in move_deprecated element function
    q!use_eval=1 formula="$unit || $service"!
]);

# renamed element in Unit
say "Handling move of OnFailureIsolate to OnFailureJobMode in unit";
$meta_root->load( steps => [
    'class:Systemd::Section::Unit',
    q!element:OnFailureIsolate type=leaf value_type=uniline status=deprecated!,
    q!warn="OnFailureIsolate is now OnFailureJobMode." -!,
    q!element:OnFailureJobMode!,
    q!migrate_from variables:unit="- OnFailureIsolate"!,
    q!formula="$unit"!
]);


say "Saving systemd model...";
$rw_obj->write_all;

say "Done.";