mirror of
https://github.com/HDFGroup/hdf5.git
synced 2024-11-27 02:10:55 +08:00
140 lines
4.5 KiB
Perl
Executable File
140 lines
4.5 KiB
Perl
Executable File
#!/usr/bin/env perl
|
||
require 5.003;
|
||
use warnings;
|
||
use Text::Tabs;
|
||
|
||
# NOTE: THE FORMAT OF HRETURN_ERROR AND HGOTO_ERROR MACROS HAS
|
||
# CHANGED. THIS SCRIPT NO LONGER WORKS! --rpm
|
||
|
||
# Copyright by The HDF Group.
|
||
# Copyright by the Board of Trustees of the University of Illinois.
|
||
# All rights reserved.
|
||
#
|
||
# This file is part of HDF5. The full HDF5 copyright notice, including
|
||
# terms governing use, modification, and redistribution, is contained in
|
||
# the COPYING file, which can be found at the root of the source code
|
||
# distribution tree, or in https://support.hdfgroup.org/ftp/HDF5/releases.
|
||
# If you do not have access to either file, you may request a copy from
|
||
# help@hdfgroup.org.
|
||
#
|
||
# Robb Matzke
|
||
# 30 Aug 1997
|
||
#
|
||
# Purpose: This script will read standard input which should be a
|
||
# function prologue followed by a C function and will emit
|
||
# on standard output the same source code with the function
|
||
# prologue containing documentation for the various errors
|
||
# that occur in the function.
|
||
#
|
||
# Errors are raised by calling HGOTO_ERROR() or
|
||
# HRETURN_ERROR(). The reason for the error message is a
|
||
# comment which appears immediately after the error macro
|
||
# call and is contained entirely on one line:
|
||
#
|
||
# HRETURN_ERROR (...); /*entry not found*/
|
||
#
|
||
# If such a comment doesn't exist, then the previous comment
|
||
# is used, subject to the constraint that raising an error
|
||
# clears the previous comment.
|
||
#
|
||
# /* Entry not found */
|
||
# HGOTO_ERROR (...);
|
||
#
|
||
# Emacs users can use this script interactively with the
|
||
# c-mark-function and shell-command-on-region functions which
|
||
# are normally bound to M-C-h and M-|.
|
||
|
||
|
||
# Split STDIN into the prolog and the function body. Preserve leading
|
||
# white space.
|
||
$_ = join "", <STDIN>;
|
||
my ($head, $prolog, $body) = (/^(\s*)(\/\*(.*?)\*\/)?(.*)/s)[0,2,3];
|
||
$prolog = "" unless $prolog;
|
||
|
||
# Find each error and the comment that goes with it.
|
||
for ($_=$body,$comment=""; /\/\*|H(RETURN|GOTO)_ERROR/s;) {
|
||
$_ = $&.$';
|
||
|
||
if (/^H(RETURN|GOTO)_ERROR\s*\(\s*H5E_(\w+)\s*,\s*H5E_(\w+)\s*,/s) {
|
||
($major, $minor, $_) = ($2, $3, $');
|
||
$comment=$1 if /^.*?\)\s*;\s*\/\*\s*(.*?)\s*\*\//;
|
||
$comment =~ s/^\s*\*+\s*/ /mg; # leading asterisks.
|
||
$comment =~ s/^\s+//s; # leading white space.
|
||
$comment =~ s/\s+$//s; # trailing white space.
|
||
$comment =~ s/(\w)$/$1./s; # punctuation.
|
||
$comment ||= "***NO COMMENT***";
|
||
$errors{"$major\000$minor\000\u$comment"} = 1;
|
||
$comment = "";
|
||
|
||
} else {
|
||
($comment) = /^\/\*\s*(.*?)\s*\*\//s;
|
||
$_ = $';
|
||
}
|
||
}
|
||
|
||
|
||
# Format an error so it isn't too wide.
|
||
sub fmt_error ($) {
|
||
local ($_) = @_;
|
||
|
||
my ($prefix,$space,$err) = /^((.*?)([A-Z_0-9]+\s+[A-Z_0-9]+\s+))/;
|
||
$_ = $';
|
||
tr/\n / /s;
|
||
my $w = 70 - length expand $prefix;
|
||
s/(.{$w}\S+)\s+(\S)/$1."\n".$space.' 'x(length $err).$2/eg;
|
||
return $prefix . $_."\n";
|
||
}
|
||
|
||
|
||
|
||
# Sort the errors by major, then minor, then comment. Duplicate
|
||
# triplets have already been removed.
|
||
sub by_triplet {
|
||
my ($a_maj, $a_min, $a_com) = split /\000/, $a;
|
||
my ($b_maj, $b_min, $b_com) = split /\000/, $b;
|
||
$a_maj cmp $b_maj || $a_min cmp $b_min || $a_com cmp $b_com;
|
||
}
|
||
@errors = map {sprintf "%-9s %-13s %s\n", split /\000/}
|
||
sort by_triplet keys %errors;
|
||
|
||
|
||
|
||
# Add the list of errors to the prologue depending on the type of
|
||
# prolog.
|
||
if (($front, $back) = $prolog=~/^(.*?Errors:\s*?(?=\n)).*?\n\s*\*\s*\n(.*)/s) {
|
||
#| * Errors: |#
|
||
#| * __list_of_error_messages__ (zero or more lines) |#
|
||
#| * |#
|
||
print $head, "/*", $front, "\n";
|
||
map {print fmt_error " *\t\t".$_} @errors;
|
||
print " *\n", $back, "*/", $body;
|
||
|
||
} elsif (($front,$back) = $prolog =~
|
||
/(.*?\n\s*ERRORS:?\s*?(?=\n)).*?\n\s*\n(.*)/s) {
|
||
#| ERRORS |#
|
||
#| __list_of_error_messages__ (zero or more lines) |#
|
||
#| |#
|
||
print $head, "/*", $front, "\n";
|
||
map {print fmt_error " ".$_} @errors;
|
||
print "\n", $back, "*/", $body;
|
||
|
||
} elsif ($prolog eq "") {
|
||
# No prolog present.
|
||
print $head;
|
||
print " \n/*", "-"x73, "\n * Function:\t\n *\n * Purpose:\t\n *\n";
|
||
print " * Errors:\n";
|
||
map {print fmt_error " *\t\t".$_} @errors;
|
||
print " *\n * Return:\tSuccess:\t\n *\n *\t\tFailure:\t\n *\n";
|
||
print " * Programmer:\t\n *\n * Modifications:\n *\n *", '-'x73, "\n";
|
||
print " */\n", $body;
|
||
|
||
} else {
|
||
# Prolog format not recognized.
|
||
print $head, "/*", $prolog, "*/\n\n";
|
||
print "/*\n * Errors returned by this function...\n";
|
||
map {print fmt_error " *\t".$_} @errors;
|
||
print " */\n", $body;
|
||
}
|
||
|
||
|