/*
 * Copyright (c) 1983, 1993
 *      The Regents of the University of California.  All rights reserved.
 *
 * This code is derived from software contributed to Berkeley by
 * Asa Romberger and Jerry Berkman.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. Neither the name of the University nor the names of its contributors
 *    may be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

#include <sys/cdefs.h>
#ifndef lint
__COPYRIGHT("@(#) Copyright (c) 1983, 1993\
 The Regents of the University of California.  All rights reserved.");
#endif /* not lint */

#ifndef lint
#if 0
static char sccsid[] = "from: @(#)fsplit.c      8.1 (Berkeley) 6/6/93";
#else
__RCSID("$NetBSD: fsplit.c,v 1.30 2015/06/16 22:54:10 christos Exp $");
#endif
#endif /* not lint */

#include <sys/types.h>
#include <sys/stat.h>

#include <assert.h>
#include <ctype.h>
#include <err.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>

/*
 *      usage:          fsplit [-e efile] ... [file]
 *
 *      split single file containing source for several fortran programs
 *              and/or subprograms into files each containing one
 *              subprogram unit.
 *      each separate file will be named using the corresponding subroutine,
 *              function, block data or program name if one is found; otherwise
 *              the name will be of the form mainNNN.f or blkdtaNNN.f .
 *              If a file of that name exists, it is saved in a name of the
 *              form zzz000.f .
 *      If -e option is used, then only those subprograms named in the -e
 *              option are split off; e.g.:
 *                      fsplit -esub1 -e sub2 prog.f
 *              isolates sub1 and sub2 in sub1.f and sub2.f.  The space
 *              after -e is optional.
 *
 *      Modified Feb., 1983 by Jerry Berkman, Computing Services, U.C. Berkeley.
 *              - added comments
 *              - more function types: double complex, character*(*), etc.
 *              - fixed minor bugs
 *              - instead of all unnamed going into zNNN.f, put mains in
 *                mainNNN.f, block datas in blkdtaNNN.f, dups in zzzNNN.f .
 */

#define BSZ 512
static char buf[BSZ];
static FILE *ifp;

static char x[] = "zzz000.f";
static char mainp[] = "main000.f";
static char blkp[] = "blkdta000.f";

__dead static void badparms(void);
static const char *functs(const char *);
static int get_line(void);
static void get_name(char *, int);
static int lend(void);
static int lname(char *, size_t);
static const char *look(const char *, const char *);
static int saveit(const char *);
static int scan_name(char *, size_t, const char *);
static const char *skiplab(const char *);
static const char *skipws(const char *);

struct extract {
        bool found;
        char *name;
};

#define MAXEXTONLY 100
static struct extract extonly[MAXEXTONLY];
static int numextonly = 0;

int
main(int argc, char **argv)
{
        FILE *ofp;      /* output file */
        int rv;         /* 1 if got card in output file, 0 otherwise */
        int nflag;      /* 1 if got name of subprog., 0 otherwise */
        int retval, i, ch;
        char name[80];

        while ((ch = getopt(argc, argv, "e:")) != -1) {
                switch (ch) {
                    case 'e':
                        if (numextonly >= MAXEXTONLY) {
                                errx(1, "Too many -e options");
                        }
                        extonly[numextonly].name = optarg;
                        extonly[numextonly].found = false;
                        numextonly++;
                        break;
                    default:
                        badparms();
                        break;
                }
        }

        if (argc > 2) {
                badparms();
        } else if (argc == 2) {
                if ((ifp = fopen(argv[1], "r")) == NULL) {
                        err(1, "%s", argv[1]);
                }
        } else {
                ifp = stdin;
        }

        for (;;) {
                /*
                 * Look for a temp file that doesn't correspond to an
                 * existing file.
                 */

                get_name(x, 3);
                ofp = fopen(x, "w");
                if (ofp == NULL) {
                        err(1, "%s", x);
                }
                nflag = 0;
                rv = 0;
                while (get_line() > 0) {
                        rv = 1;
                        fprintf(ofp, "%s", buf);
                        /* look for an 'end' statement */
                        if (lend()) {
                                break;
                        }
                        /* if no name yet, try and find one */
                        if (nflag == 0) {
                                nflag = lname(name, sizeof(name));
                        }
                }
                fclose(ofp);
                if (rv == 0) {
                        /* no lines in file, forget the file */
                        unlink(x);
                        retval = 0;
                        for (i = 0; i < numextonly; i++) {
                                if (!extonly[i].found) {
                                        retval = 1;
                                        warnx("%s not found", extonly[i].name);
                                }
                        }
                        exit(retval);
                }
                if (nflag) {
                        /* rename the file */
                        if (saveit(name)) {
                                struct stat sbuf;

                                if (stat(name, &sbuf) < 0) {
                                        if (rename(x, name) < 0) {
                                                warn("%s: rename", x);
                                                printf("%s left in %s\n",
                                                    name, x);
                                        } else {
                                                printf("%s\n", name);
                                        }
                                        continue;
                                } else if (strcmp(name, x) == 0) {
                                        printf("%s\n", x);
                                        continue;
                                }
                                printf("%s already exists, put in %s\n",
                                    name, x);
                                continue;
                        } else {
                                unlink(x);
                                continue;
                        }
                }
                if (numextonly == 0) {
                        printf("%s\n", x);
                } else {
                        unlink(x);
                }
        }
}

static void
badparms(void)
{
        err(1, "Usage: fsplit [-e efile] ... [file]");
}

static int
saveit(const char *name)
{
        int i;
        char fname[50];
        size_t fnamelen;

        if (numextonly == 0) {
                return 1;
        }
        strlcpy(fname, name, sizeof(fname));
        fnamelen = strlen(fname);
        /* Guaranteed by scan_name.  */
        assert(fnamelen > 2);
        assert(fname[fnamelen-2] == '.');
        assert(fname[fnamelen-1] == 'f');
        fname[fnamelen-2] = '\0';

        for (i = 0; i < numextonly; i++) {
                if (strcmp(fname, extonly[i].name) == 0) {
                        extonly[i].found = true;
                        return 1;
                }
        }
        return 0;
}

static void
get_name(char *name, int letters)
{
        struct stat sbuf;
        char *ptr;

        while (stat(name, &sbuf) >= 0) {
                for (ptr = name + letters + 2; ptr >= name + letters; ptr--) {
                        (*ptr)++;
                        if (*ptr <= '9')
                                break;
                        *ptr = '0';
                }
                if (ptr < name + letters) {
                        errx(1, "Ran out of file names.");
                }
        }
}

static int
get_line(void)
{
        char *ptr;

        for (ptr = buf; ptr < &buf[BSZ]; ) {
                *ptr = getc(ifp);
                if (feof(ifp))
                        return -1;
                if (*ptr++ == '\n') {
                        *ptr = '\0';
                        return 1;
                }
        }
        while (getc(ifp) != '\n' && feof(ifp) == 0) {
                /* nothing */
        }
        warnx("Line truncated to %d characters.", BSZ);
        return 1;
}

/*
 * Return 1 for 'end' alone on card (up to col. 72), 0 otherwise.
 */
static int
lend(void)
{
        const char *p;

        if ((p = skiplab(buf)) == 0) {
                return 0;
        }
        p = skipws(p);
        if (*p != 'e' && *p != 'E') {
                return 0;
        }
        p++;
        p = skipws(p);
        if (*p != 'n' && *p != 'N') {
                return 0;
        }
        p++;
        p = skipws(p);
        if (*p != 'd' && *p != 'D') {
                return 0;
        }
        p++;
        p = skipws(p);
        if (p - buf >= 72 || *p == '\n') {
                return 1;
        }
        return 0;
}

/*
 * check for keywords for subprograms
 * return 0 if comment card, 1 if found
 * name and put in arg string. invent name for unnamed
 * block datas and main programs.
 */
static int
lname(char *s, size_t l)
{
#define LINESIZE 80
        const char *ptr, *p;
        char line[LINESIZE], *iptr = line;

        /* first check for comment cards */
        if (buf[0] == 'c' || buf[0] == 'C' || buf[0] == '*') {
                return 0;
        }
        ptr = skipws(buf);
        if (*ptr == '\n') {
                return 0;
        }

        ptr = skiplab(buf);
        if (ptr == NULL) {
                return 0;
        }

        /*  copy to buffer and converting to lower case */
        p = ptr;
        while (*p && p <= &buf[71] ) {
           *iptr = tolower((unsigned char)*p);
           iptr++;
           p++;
        }
        *iptr = '\n';

        if ((ptr = look(line, "subroutine")) != NULL ||
            (ptr = look(line, "function")) != NULL ||
            (ptr = functs(line)) != NULL) {
                if (scan_name(s, l, ptr)) {
                        return 1;
                }
                strlcpy(s, x, l);
        } else if ((ptr = look(line, "program")) != NULL) {
                if (scan_name(s, l, ptr)) {
                        return 1;
                }
                get_name(mainp, 4);
                strlcpy(s, mainp, l);
        } else if ((ptr = look(line, "blockdata")) != NULL) {
                if (scan_name(s, l, ptr)) {
                        return 1;
                }
                get_name(blkp, 6);
                strlcpy(s, blkp, l);
        } else if ((ptr = functs(line)) != NULL) {
                if (scan_name(s, l, ptr)) {
                        return 1;
                }
                strlcpy(s, x, l);
        } else {
                get_name(mainp, 4);
                strlcpy(s, mainp, l);
        }
        return 1;
}

static int
scan_name(char *s, size_t smax, const char *ptr)
{
        char *sptr;
        size_t sptrmax;

        /* scan off the name */
        ptr = skipws(ptr);
        sptr = s;
        sptrmax = smax - 3;
        while (*ptr != '(' && *ptr != '\n') {
                if (*ptr != ' ' && *ptr != '\t' && *ptr != '/') {
                        if (sptrmax == 0) {
                                /* Not sure this is the right thing, so warn */
                                warnx("Output name too long; truncated");
                                break;
                        }
                        *sptr++ = *ptr;
                        sptrmax--;
                }
                ptr++;
        }

        if (sptr == s) {
                return 0;
        }

        *sptr++ = '.';
        *sptr++ = 'f';
        *sptr++ = '\0';
        return 1;
}

/*
 * look for typed functions such as: real*8 function,
 * character*16 function, character*(*) function
 */
static const char *
functs(const char *p)
{
        const char *ptr;

        if ((ptr = look(p, "character")) != NULL ||
            (ptr = look(p, "logical")) != NULL ||
            (ptr = look(p, "real")) != NULL ||
            (ptr = look(p, "integer")) != NULL ||
            (ptr = look(p, "doubleprecision")) != NULL ||
            (ptr = look(p, "complex")) != NULL ||
            (ptr = look(p, "doublecomplex")) != NULL) {
                while (*ptr == ' ' || *ptr == '\t' || *ptr == '*'
                    || (*ptr >= '0' && *ptr <= '9')
                    || *ptr == '(' || *ptr == ')') {
                        ptr++;
                }
                ptr = look(ptr, "function");
                return ptr;
        }
        else {
                return NULL;
        }
}

/*
 * if first 6 col. blank, return ptr to col. 7,
 * if blanks and then tab, return ptr after tab,
 * else return NULL (labelled statement, comment or continuation)
 */
static const char *
skiplab(const char *p)
{
        const char *ptr;

        for (ptr = p; ptr < &p[6]; ptr++) {
                if (*ptr == ' ')
                        continue;
                if (*ptr == '\t') {
                        ptr++;
                        break;
                }
                return NULL;
        }
        return ptr;
}

/*
 * return NULL if m doesn't match initial part of s;
 * otherwise return ptr to next char after m in s
 */
static const char *
look(const char *s, const char *m)
{
        const char *sp, *mp;

        sp = s; mp = m;
        while (*mp) {
                sp = skipws(sp);
                if (*sp++ != *mp++)
                        return NULL;
        }
        return sp;
}

static const char *
skipws(const char *p)
{
        while (*p == ' ' || *p == '\t') {
                p++;
        }
        return p;
}