wrapxs.pm

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

        }
    }

    my $cnvprefix =  $self -> my_cnv_prefix ;
    my $typemap_code = $typemap -> typemap_code ($cnvprefix);

    
    foreach my $dir ('INPUT', 'OUTPUT') {
        print $fh "\n$dir\n" ;
        while (my($type, $code) = each %{$typemap_code}) {
            print $fh "$type\n$code->{$dir}\n\n" if ($code->{$dir}) ;
        }
    }

    close $fh;
}

# ============================================================================

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

    $method = $method . '_code';
    my($h, $code) = $self->typemap->$method();
    my $file = join '/', $self->{XS_DIR}, $h;

    open my $fh, '>', $file or die "open $file: $!";
    print $fh "$self->{noedit_warning_c}\n";
    print $fh $code;
    close $fh;
}

# ============================================================================

sub _pod_gen_siglet {

   my $class = shift || '' ;

   return '\%' if $class eq 'HV';
   return '\@' if $class eq 'AV';
   return '$';
}

# ============================================================================
# Determine if the name is that of a function or an object

sub _pod_is_function {

   my $class = shift || '';

#print "_pod_is_function($class)\n";

   my %func_class = (
      SV => 1,
      IV => 1,
      NV => 1,
      PV => 1,
      UV => 1,
     PTR => 1,
   );

   exists $func_class{$class};
}

# ============================================================================

sub generate_pod {

    my $self = shift ;
    my $fh   = shift;
    my $pdd  = shift;
    my $templ = $self -> new_podtemplate ; 
    
    my $since = $templ -> since_default ; 
    print $fh $templ -> gen_pod_head ($pdd->{module}) ;

    my $detail = $pdd->{functions_detailed};

    unless ( ref($detail) eq 'ARRAY') {
      warn "No functions listed in pdd structure for $pdd->{module}";
      return;
    }


    foreach my $f (@$detail) {

        # Generate the function or method name

        my $method = $f->{perl_name};
        $method = $1 if ($f->{prefix} && ($method =~ /^$f->{prefix}(.*?)$/)) ;
        $method = $1 if ($f->{class_xs_prefix} && ($method =~ /^(?:DEFINE_)?$f->{class_xs_prefix}(.*?)$/)) ;

        if (!$method) {
            warn "Cannot determinate method name for '$f->{name}'" ;
            next ;
        }
        my $comment = $f->{comment_parsed};
        my $commenttext = ($comment->{func_desc} || '') . "\n\n" . ($comment->{doxygen_remark} || '') ;
        my $member  = $f -> {struct_member};
        if ($member)
            {
            print $fh $templ -> gen_pod_struct_member ($f->{class}, '$obj', $f->{struct_member}->{class}, $f->{perl_name}, $commenttext, $since) ;
            }
        else
            {
            my $args    = $f->{args};
            if ($args && @$args)
                {
                my @param_nm = map { $_ -> {name} } @$args ;  # Parameter names
                my $obj_nm;
                my $obj_sym;
                my $offset = 0;

                my $first_param = $f->{args}[0];
                unless (_pod_is_function($first_param->{class})) {
                    $obj_nm  = $param_nm[0];             # Object Name
                    $obj_sym = &_pod_gen_siglet($first_param->{class}). $obj_nm;
                    $offset++;
                }

               
                my $retclass ;
                my $retcomment = $comment -> {doxygen_return} || '' ;

                if ($f -> {return_type}  && $f -> {return_type} ne 'void') {
                    my $rettype = $self -> typemap->get->{$f -> {return_type}} ;
                    $retclass = $rettype?$rettype->{class}:$f -> {return_type};
                }



                my @param;
                my $i = 0 ;
                for my $param_nm (@param_nm) {
                    my $arg = $args->[$i++];
                    push @param, { class => $arg->{class}, name => &_pod_gen_siglet($arg->{class}) . $param_nm, 
                                    comment => ($comment->{doxygen_param_desc}{$param_nm} || '') } ;
                }

                print $fh $templ -> gen_pod_func ($obj_sym, $obj_sym, $method, \@param, $retclass, $retcomment, $commenttext, $since) ;
            }    
        }
    }
}



# ============================================================================

# pdd = PERL Data Dumper
sub write_docs {
    my($self, $module, $functions) = @_;

    my $fh = $self->open_class_file($module, '.pdd');
    print $fh "$self->{noedit_warning_hash}\n";

    # Includes
    my @includes = @{ $self->includes };

    if (my $mod_h = $self->mod_h($module)) {
        push @includes, $mod_h;
    }

    my $last_prefix = "";
    my $fmap = $self->typemap->{function_map} ;
    my $myprefix = $self->my_xs_prefix ;

    # Finding doxygen- and other data inside the comments

    # This code only knows the syntax for @ingroup, @param, @remark,
    # @return and @warning. At the moment all other doxygen commands
    # are treated as multiple-occurance, no-parameter commands.

    # Note: Nor does @deffunc exist in the doxygen specification,
    # neither does @remark (but @remarks), @tip and @see. So we treat
    # @remark like @remarks, but we don't do any speacial treating for
    # @deffunc.  Ideas or suggestions anyone?

    # --Axel Beckert 

    foreach my $details (@$functions) {
	#print "Comment: ", $details->{name} || '?', ':  ', $details->{comment} || '-', "\n" ;
        #print "----> ", Dumper ($details) ;# if (!$details->{comment}) ;

        if (defined $details->{comment} and  
	    my $comment = $details->{comment}) {
	    $details->{comment_parsed} = {};

	    # Source file
	    if ($comment =~ s/^\s*(\S*\.c)\s+\*\n//s) {
		$details->{comment_parsed}{source_file} = $1;
	    }

	    # Initialize several fields
	    $details->{comment_parsed}{func_desc} = "";
	    my $doxygen = 0; # flag indicating that we already have
	                     # seen doxygen fields in this comment
	    my $type = 0; # name of doxygen field
	    my $pre = 0; # if we should recognize leading
	                 # spaces. Example see apr_table_overlap
	    # Setting some regexps
	    my $ordinary_line = qr/^\s*?\*(\s*(.*?))\s*$/;
	    my $pre_begin = qr(<PRE>)i;
	    my $pre_end = qr(</PRE>)i;

	    # Parse the rest of the comment line by line, because
	    # doxygen fields can appear more than once
	    foreach my $line (split /\n/, $comment) {

		# Yesss! This looks like doxygen data. 
		if ($line =~ /^\s*\*\s+[\\@](\w+)\s+(.*)\s*$/) {
		    $type = $doxygen = $1;
		    my $info = $2;

		    # setting the recognizing of leading spaces
		    $pre = ($info =~ $pre_begin ? 1 : $pre);
		    $pre = ($info =~ $pre_end ? 0 : $pre);
		    
		    # Already had a doxygen element of this type for this func.
		    if (defined $details->{comment_parsed}{"doxygen_$type"}) {
			push(@{ $details->{comment_parsed}{"doxygen_$type"} },
			     $info);
		    } 
		    # Hey, hadn't seen this doxygen type in this function yet!
		    else {
			$details->{comment_parsed}{"doxygen_$type"} = [ $info ];
		    }
		} 
		# Further line belonging to doxygen field of the last line
		elsif ($doxygen) {
		    # An empty line ends a doxygen paragraph
		    if ($line =~ /^\s*$/) {
			$doxygen = 0;
			next;
		    }

		    # Those two situations should never appear. But we
		    # better double check those things.
		    croak("There already was a doxygen comment, but it didn't set an type.\nStrange things happen")
			unless defined $details->{comment_parsed}{"doxygen_$type"};
		    croak("This ($line) maybe an syntactic incorrect doxygen line.\nStrange things happen")
			unless $line =~ $ordinary_line;
		    my $info = $2;
		    $info = $1 if $pre;

		    # setting the recognizing of leading spaces
		    $pre = ($info =~ $pre_begin ? 1 : $pre);
		    $pre = ($info =~ $pre_end ? 0 : $pre);
		    $info =~ s(^\s+</PRE>)(</PRE>)i;

		    # Ok, get me the last line of documentation.
		    my $lastline = 
			pop @{ $details->{comment_parsed}{"doxygen_$type"} };

		    # Concatenate that line and the actual line with a newline
		    $info = "$lastline\n$info";

		    # Strip empty lines at the end and beginning
		    # unless there was a <PRE> before.
		    unless ($pre) {
			$info =~ s/[\n\s]+$//s;
			$info =~ s/^[\n\s]+//s;
		    }

		    # Push the back into the array 
		    push(@{ $details->{comment_parsed}{"doxygen_$type"} }, 
			 $info);
		}
		# Booooh! Just an ordinary comment
		elsif ($line =~ $ordinary_line) {
		    my $info = $2;
		    $info = $1 if $pre;

		    # setting the recognizing of leading spaces
		    $pre = ($info =~ $pre_begin ? 1 : $pre);
		    $pre = ($info =~ $pre_end ? 0 : $pre);
		    $info =~ s(^\s+(</PRE>))($1)i;

		    # Only add if not an empty line at the beginning
		    $details->{comment_parsed}{func_desc} .= "$info\n"
			unless ($info =~ /^\s*$/ and 
				$details->{comment_parsed}{func_desc} eq "");
		} else {
		    if (defined $details->{comment_parsed}{unidentified}) {
			push(@{ $details->{comment_parsed}{unidentified} }, 
			     $line);
		    } else {
			$details->{comment_parsed}{unidentified} = [ $line ];
		    }
		}
	    }

	    # Unnecessary linebreaks at the end of the function description
	    $details->{comment_parsed}{func_desc} =~ s/[\n\s]+$//s
		if defined $details->{comment_parsed}{func_desc};

	    if (defined $details->{comment_parsed}{doxygen_param}) {
		# Remove the description from the doxygen_param and
		# move into an hash. A sole hash doesn't work, because
		# it usually screws up the parameter order

		my %param; my @param;
		foreach (@{ $details->{comment_parsed}{doxygen_param} }) {
		    my ($var, $desc) = split(" ",$_,2);
		    $param{$var} = $desc;
		    push(@param, $var);
		}
		$details->{comment_parsed}{doxygen_param} = [ @param ];
		$details->{comment_parsed}{doxygen_param_desc} = { %param };
	    }

	    if (defined $details->{comment_parsed}{doxygen_defgroup}) {
		# Change doxygen_defgroup from array to hash

		my %defgroup;
		foreach (@{ $details->{comment_parsed}{doxygen_defgroup} }) {
		    my ($var, $desc) = split(" ",$_,2);
		    $defgroup{$var} = $desc;
		}
		$details->{comment_parsed}{doxygen_defgroup} = { %defgroup };
	    }

	    if (defined $details->{comment_parsed}{doxygen_ingroup}) {
		# There should be a list of all parameters

		my @ingroup = ();
		foreach (@{ $details->{comment_parsed}{doxygen_ingroup} }) {
		    push(@ingroup, split());
		}
		$details->{comment_parsed}{doxygen_ingroup} = [ @ingroup ];
	    }

	    foreach (qw(return warning remark)) {
		if (defined $details->{comment_parsed}{"doxygen_$_"}) {
		    # Multiple adjacent @$_ should be concatenated, so
		    # we can make an scalar out of it. Although we
		    # actually still disregard the case, that there
		    # are several non-adjacent @$_s.
		    $details->{comment_parsed}{"doxygen_$_"} = 
			join("\n", 
			     @{ $details->{comment_parsed}{"doxygen_$_"} });
		}
	    }

	    # Dump the output for debugging purposes
#	    print STDERR "### $details->{perl_name}:\n".
#		Dumper $details->{comment_parsed};
#	    print STDERR "### Original Comment:\n".
#		Dumper $details->{comment};
	    
	}

	# Some more per function information, used in the XS files
        my $class = $details->{class};
        if ($class) {
            my $prefix = $details->{prefix};
            $last_prefix = $prefix if $prefix;
	    
            if ($details->{name} =~ /^$myprefix/o) {
                #e.g. mpxs_Apache__RequestRec_
                my $class_prefix = $fmap -> class_c_prefix($class);
                if ($details->{name} =~ /$class_prefix/) {
                    $details->{class_xs_prefix} = 
			$fmap->class_xs_prefix($class);
                }
		$details->{class_c_prefix} =  $class_prefix;		
            }
	}
    }


    # Some more information, used in the XS files
    my $destructor = $self->typemap->destructor($last_prefix);
    my $boot = $self->boot($module);
    if ($boot) {
	chomp($boot);
	$boot =~ s/(\s+$|^\s+)//;
    }
    my $newxs = $self->{newXS}->{$module};

    # Finally do the PDD Dump
    my $pdd = {
	module => $module, 
	functions => [ map $$_{perl_name}, @$functions ],
	functions_detailed => [ @$functions ],
	includes => [ @includes ],
	my_xs_prefix => $myprefix,
	destructor => $destructor,
	boot => $boot,
	newXS => $newxs
    };

    print $fh Dumper $pdd;
    close $fh;

    $fh = $self->open_class_file($module, '.pod');
    $self -> generate_pod($fh, $pdd);
    close $fh;
}

# ============================================================================

sub generate {
    my $self = shift;

    $self->prepare;

    # now done by write_missing_makefilepls
    #for (qw(ModPerl::WrapXS Apache APR)) {
    #    $self->write_makefilepl($_);
    #}

    $self->write_typemap;

    for (qw(typedefs sv_convert)) {
        $self->write_typemap_h_file($_);
    }

    $self->get_functions;
    $self->get_structures;

    while (my($module, $functions) = each %{ $self->{XS} }) {
#        my($root, $sub) = split '::', $module;
#        if (-e "$self->{XS_DIR}/$root/$sub/$sub.xs") {
#            $module = join '::', $root, "Wrap$sub";
#        }
        if (!$module)
            {
            print "WARNING: empty module\n" ;
            next ;
            }
        print "mod $module\n" ;
        $self->write_makefilepl($module);
        $self->write_xs($module, $functions);
        $self->write_pm($module);
        $self->write_docs($module, $functions);
    }

    $self -> write_missing_makefilepls ;
}

# ============================================================================

sub stats {
    my $self = shift;

    $self->get_functions;
    $self->get_structures;

    my %stats;

    while (my($module, $functions) = each %{ $self->{XS} }) {
        $stats{$module} += @$functions;
        if (my $newxs = $self->{newXS}->{$module}) {
            $stats{$module} += @$newxs;
        }
    }

    return \%stats;
}

# ============================================================================
=pod

=head2 mapline_elem  (o, elem)

Called for each structure element that is written to the map file by
checkmaps. Allows the user to change the element name, for example
adding a different perl name.

Default: returns the element unmodified

=cut

sub mapline_elem { return $_[1] } ;

# ============================================================================
=pod

=head2 mapline_func  (o)

Called for each function that is written to the map file by checkmaps. Allows
the user to change the function name, for example adding a different perl
name.

Default: returns the element unmodified

=cut

sub mapline_func { return $_[1] } ;

# ============================================================================

sub checkmaps {
    my $self = shift;
    my $prefix = shift;

    $self = $self -> new if (!ref $self) ;

    my $result = $self -> {typemap} -> checkmaps ;    
    $self -> {typemap} -> writemaps ($result, $prefix) if ($prefix) ;    

    return $result ;
}

# ============================================================================

sub run {
    my $class = shift ;

    my $xs = $class -> new;

    $xs->generate;
}


1;
__END__